├── .envrc ├── .ghci ├── .gitignore ├── .stan.toml ├── .vscode ├── extensions.json ├── settings.json └── tasks.json ├── LICENSE.md ├── README.md ├── Setup.hs ├── app ├── Control │ └── Timeout.hs ├── Frugel │ └── Web │ │ ├── Action.hs │ │ ├── Event.hs │ │ ├── Internal │ │ └── Model.hs │ │ ├── Model.hs │ │ ├── View.hs │ │ └── View │ │ ├── Elements.hs │ │ └── Rendering.hs ├── Language │ └── Javascript │ │ └── JSaddle │ │ └── Warp │ │ └── Extra.hs └── Main.hs ├── base.nix ├── cabal.project ├── default.nix ├── floskell.json ├── frugel.cabal ├── hie.yaml ├── nix-stack.yaml ├── nix ├── commit-hooks.nix ├── scripts.nix ├── sources.json └── sources.nix ├── package.yaml ├── prelude └── Prelude.hs ├── scout-src ├── BasicEvaluation.hs ├── Control │ ├── Enumerable │ │ └── Combinators.hs │ ├── Limited.hs │ ├── ValidEnumerable.hs │ └── ValidEnumerable │ │ ├── Access.hs │ │ └── Class.hs ├── Data │ ├── Alphanumeric.hs │ ├── Constrained.hs │ ├── Hidden.hs │ ├── Sized.hs │ ├── Validity │ │ └── Extra.hs │ └── Whitespace.hs ├── Frugel │ └── CstrSite │ │ └── ValidEnumerable.hs ├── Optics │ ├── Extra │ │ └── Scout.hs │ ├── Fallible.hs │ ├── ReadOnly │ │ ├── FunctorOptic.hs │ │ ├── Intro.hs │ │ └── VL.hs │ └── Writer.hs ├── PrettyPrinting │ └── Expr.hs ├── Scout.hs ├── Scout │ ├── Error.hs │ ├── Evaluation.hs │ ├── Internal │ │ ├── EvaluationEnv.hs │ │ ├── Node.hs │ │ └── Program.hs │ ├── Lexing.hs │ ├── Node.hs │ ├── Operators.hs │ ├── Orphans │ │ ├── DisplayProjection.hs │ │ ├── MultiSet.hs │ │ └── Stream.hs │ ├── Parsing.hs │ ├── Parsing │ │ ├── Error.hs │ │ └── Whitespace.hs │ ├── PrettyPrinting.hs │ ├── Program.hs │ ├── Truncatable.hs │ └── Unbound.hs └── Text │ └── Megaparsec │ └── State │ └── Optics.hs ├── shell.nix ├── src ├── Control │ └── Zipper │ │ └── Seq.hs ├── Frugel.hs ├── Frugel │ ├── Action.hs │ ├── CstrSite.hs │ ├── Decomposition.hs │ ├── DisplayProjection.hs │ ├── Error.hs │ ├── Error │ │ └── InternalError.hs │ ├── Internal │ │ ├── DecompositionState.hs │ │ └── Model.hs │ ├── Model.hs │ ├── Parsing.hs │ └── PrettyPrinting.hs └── Optics │ └── Extra │ └── Frugel.hs ├── stack.yaml ├── stack.yaml.lock ├── test ├── Data │ └── NonNegative │ │ └── GenValidity.hs ├── EvaluationSpec.hs └── Spec.hs ├── weeder.dhall └── www ├── bulma.min.css ├── index.html └── style.css /.envrc: -------------------------------------------------------------------------------- 1 | use nix -------------------------------------------------------------------------------- /.ghci: -------------------------------------------------------------------------------- 1 | :set -interactive-print Text.Show.Pretty.pPrint 2 | :set prompt "λ> " 3 | :set prompt-cont "λ| " 4 | :set -Wno-all -W -Wno-deprecations -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | result* 2 | demo exes* 3 | .pre-commit-config.yaml 4 | .hie 5 | 6 | dist 7 | dist-* 8 | cabal-dev 9 | *.o 10 | *.hi 11 | *.chi 12 | *.chs.h 13 | *.dyn_o 14 | *.dyn_hi 15 | .hpc 16 | .hsenv 17 | .cabal-sandbox/ 18 | cabal.sandbox.config 19 | *.prof 20 | *.aux 21 | *.hp 22 | *.eventlog 23 | .stack-work/ 24 | cabal.project.local 25 | cabal.project.local~ 26 | .HTF/ 27 | .ghc.environment.* 28 | -------------------------------------------------------------------------------- /.stan.toml: -------------------------------------------------------------------------------- 1 | [[check]] 2 | type = "Exclude" 3 | category = "Infinite" 4 | scope = "all" 5 | [[check]] 6 | type = "Exclude" 7 | category = "Partial" 8 | scope = "all" 9 | 10 | [[check]] 11 | type = "Exclude" 12 | id = "STAN-0213" 13 | scope = "all" 14 | [[check]] 15 | type = "Exclude" 16 | id = "STAN-0206" 17 | scope = "all" 18 | [[check]] 19 | type = "Exclude" 20 | id = "STAN-0208" 21 | scope = "all" 22 | [[check]] 23 | type = "Exclude" 24 | id = "STAN-0207" 25 | scope = "all" 26 | -------------------------------------------------------------------------------- /.vscode/extensions.json: -------------------------------------------------------------------------------- 1 | { 2 | "recommendations": [ 3 | "justusadam.language-haskell", 4 | "haskell.haskell", 5 | "cab404.vscode-direnv" 6 | ] 7 | } -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "cSpell.words": [ 3 | "agda", 4 | "bimap", 5 | "Bindees", 6 | "Bitraversable", 7 | "bitraversal", 8 | "bitraverse", 9 | "concat", 10 | "Decomposables", 11 | "fmap", 12 | "frugel", 13 | "gadts", 14 | "gmail", 15 | "hypertypes", 16 | "impredicative", 17 | "layoutable", 18 | "Monoidal", 19 | "monospace", 20 | "projectional", 21 | "reannotate", 22 | "reannotated", 23 | "Redex", 24 | "relude", 25 | "snoc", 26 | "stylesheet", 27 | "traversers", 28 | "Truncatable", 29 | "uncurry", 30 | "vdom", 31 | "WHNF" 32 | ], 33 | "cSpell.ignoreWords": [ 34 | "Cond", 35 | "OVERLAPPABLE", 36 | "accum", 37 | "aconcat", 38 | "aeson", 39 | "afailing", 40 | "afold", 41 | "afolding", 42 | "atraversal", 43 | "atraverse", 44 | "bulma", 45 | "cdfa's", 46 | "colinderoos", 47 | "cstr", 48 | "deepseq", 49 | "dquotes", 50 | "exts", 51 | "fibi", 52 | "fmap", 53 | "foldl", 54 | "foldr", 55 | "gaside", 56 | "gfailing", 57 | "ghcjs", 58 | "gmappend", 59 | "gmempty", 60 | "gref", 61 | "guse", 62 | "guses", 63 | "gview", 64 | "gviews", 65 | "hcat", 66 | "hlint", 67 | "ifndef", 68 | "imapped", 69 | "ints", 70 | "iover", 71 | "itraverse", 72 | "jsaddle", 73 | "keydown", 74 | "l", 75 | "lparen", 76 | "map", 77 | "mappend", 78 | "mconcat", 79 | "mempty", 80 | "mfilter", 81 | "noinline", 82 | "of", 83 | "omap", 84 | "parens", 85 | "parseable", 86 | "pkgs", 87 | "prettyprinter", 88 | "retraverse", 89 | "rezip", 90 | "rparen", 91 | "rtsopts", 92 | "setmapped", 93 | "softline", 94 | "spanl", 95 | "spanr", 96 | "succ", 97 | "uniplate", 98 | "unlines", 99 | "unwords", 100 | "vcat", 101 | "vsep" 102 | ], 103 | "cSpell.enableFiletypes": [ 104 | "!yaml", 105 | "clojure", 106 | "coffeescript", 107 | "fsharp", 108 | "graphql", 109 | "julia", 110 | "jupyter", 111 | "literate haskell", 112 | "lua", 113 | "mdx", 114 | "objective-c", 115 | "objective-cpp", 116 | "perl", 117 | "perl6", 118 | "r", 119 | "reason", 120 | "reason_lisp", 121 | "ruby", 122 | "swift", 123 | "vue" 124 | ], 125 | "nixEnvSelector.nixFile": "${workspaceRoot}/shell.nix", 126 | "haskell.plugin.haddockComments.globalOn": false, 127 | "outline.showModules": false, 128 | "outline.showConstructors": false, 129 | } -------------------------------------------------------------------------------- /.vscode/tasks.json: -------------------------------------------------------------------------------- 1 | 2 | { 3 | // Automatically created by phoityne-vscode extension. 4 | 5 | "version": "2.0.0", 6 | "presentation": { 7 | "reveal": "always", 8 | "panel": "new" 9 | }, 10 | "tasks": [ 11 | { 12 | // F7 13 | "group": { 14 | "kind": "build", 15 | "isDefault": true 16 | }, 17 | "label": "haskell build", 18 | "type": "shell", 19 | //"command": "cabal configure && cabal build" 20 | "command": "stack build" 21 | }, 22 | { 23 | // F6 24 | "group": "build", 25 | "type": "shell", 26 | "label": "haskell clean & build", 27 | //"command": "cabal clean && cabal configure && cabal build" 28 | "command": "stack clean && stack build" 29 | //"command": "stack clean ; stack build" // for powershell 30 | }, 31 | { 32 | // F8 33 | "group": { 34 | "kind": "test", 35 | "isDefault": true 36 | }, 37 | "type": "shell", 38 | "label": "haskell test", 39 | //"command": "cabal test" 40 | "command": "stack test" 41 | }, 42 | { 43 | // F6 44 | "isBackground": true, 45 | "type": "shell", 46 | "label": "haskell watch", 47 | "command": "stack build --test --no-run-tests --file-watch" 48 | } 49 | ] 50 | } 51 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Frugel: an error tolerant live programming environment 2 | 3 | Frugel is an error tolerant live programming environment. With this we mean: 4 | 5 | - In contrast to traditional IDEs, language services keep functioning in the presence of errors. Most remarkably, any program can be interpreted to obtain (partial) runtime information, but the editor is not more restrictive in the programs it allows than standard text editors. 6 | - This programming environment supports live programming. The programmer is provided with continuous feedback on a focused part of the program behaviour. 7 | 8 | With this combination, programmers can easily observe up-to-date dynamic context around errors, which is valuable for debugging and verification and generally "fuses" the edit-compile-run cycle. 9 | 10 | To do this, the environment uses "construction sites" to isolate errors. 11 | See my [master's thesis](https://cdfa.github.io/frugel/thesis.pdf) for more details. 12 | 13 | At the moment, I do not have the time and energy to develop this prototype further. 14 | Please create an issue or pick an existing one if you would like to contribute. 15 | 16 | ## Installation 17 | 18 | Visit https://cdfa.github.io/frugel/ to try it out online, or download one of the [native binaries](https://github.com/cdfa/frugel/releases) (Recommended due to bad performance of the web version). 19 | 20 | Regarding package managers, `stack install` and `cabal install` should work out of the box. 21 | You can install one of the nix derivations from `default.nix` with `nix-env -f default.nix -iA `, e.g. `nix-env -f default.nix -iA frugel-exe`. 22 | If you add Frugel's package cache (see "Building"), you can also directly install a static Linux binary with `nix-env -i `, where the `` is mentioned in the release notes. 23 | Note that older binaries may not be available in the cache. 24 | 25 | ## Usage 26 | 27 | A [demo video](https://archive.org/details/demo_20220123) and [a presentation](https://archive.org/details/presentation_202201) can be found on the Internet Archive. 28 | The demo video shows the features of the programming environment in action with some examples. 29 | The presentation gives an overview of the design and motivations. 30 | 31 | ## Building 32 | 33 | You can build the programming environment with either `stack`, `cabal` or `nix`. Building with cabal has only been tested on Windows and the stack configuration was only tested on OSX. Nix is the only supported system for building the web-version and may provide better reproducibility than cabal or stack. 34 | 35 | ### Nix 36 | 37 | I recommend adding Frugel's package cache to you nix configuration with `cachix use frugel`. 38 | Building was tested with nix version `2.3.16`. 39 | Build native executables for Linux (musl64) with `nix-build -A frugel-static`. 40 | The web version can be built with `nix-build -A frugel-web`. 41 | Building the web version may take more than 16GB of RAM. Part of this may be swapped. 42 | 43 | ### Stack 44 | 45 | ``` 46 | stack build 47 | ``` 48 | 49 | ### Cabal 50 | 51 | ``` 52 | cabal build 53 | ``` 54 | 55 | ## Contributing 56 | 57 | I recommend using the `shell.nix` environment when working on this project. 58 | It includes several tools and git hooks. 59 | I will try to provide complete documentation of the development environment on my machine soon. 60 | 61 | The current implementation of evaluation is a bit of a mess (abuse of the `ExprMeta` fields), since I was in a rush to finish it. 62 | A less confusing version that implements some core functionality can be found in `scout-src/BasicEvaluation.hs`. 63 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Control/Timeout.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Control.Timeout where 4 | 5 | import Control.Concurrent 6 | import Control.Exception 7 | 8 | #if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS) 9 | import GHC.Event 10 | #endif 11 | 12 | unlessFinishedIn :: Int -> IO () -> (MVar ThreadId -> IO a) -> IO a 13 | unlessFinishedIn delay handler action 14 | | delay <= 0 = do 15 | handlerThreadVar <- newMVar =<< forkIO handler 16 | action handlerThreadVar 17 | #if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS) 18 | unlessFinishedIn delay handler action = do 19 | timerManager <- getSystemTimerManager 20 | handlerThreadVar <- newEmptyMVar 21 | let handleTimeout = do 22 | timedActionNotFinished <- isEmptyMVar handlerThreadVar 23 | when timedActionNotFinished . void . forkIO $ do 24 | timedActionNotFinished2 25 | <- tryPutMVar handlerThreadVar =<< myThreadId 26 | when timedActionNotFinished2 handler 27 | cleanupTimeout key = uninterruptibleMask_ $ do 28 | handlerNotStarted <- tryPutMVar handlerThreadVar 29 | $ error "handler thread id evaluated by handler" 30 | when handlerNotStarted $ do 31 | unregisterTimeout timerManager key 32 | bracket (registerTimeout timerManager delay handleTimeout) cleanupTimeout 33 | . const 34 | $ action handlerThreadVar 35 | #else 36 | unlessFinishedIn delay handler action = do 37 | handlerThreadVar <- newEmptyMVar 38 | let handleTimeout unmask = do 39 | void . unmask $ threadDelay delay 40 | putMVar handlerThreadVar =<< myThreadId 41 | handler 42 | cleanupHandler handlerId = uninterruptibleMask_ $ do 43 | handlerNotStarted <- isEmptyMVar handlerThreadVar 44 | when handlerNotStarted $ killThread handlerId 45 | bracket (forkIOWithUnmask handleTimeout) cleanupHandler . const 46 | $ action handlerThreadVar 47 | #endif 48 | -------------------------------------------------------------------------------- /app/Frugel/Web/Action.hs: -------------------------------------------------------------------------------- 1 | module Frugel.Web.Action where 2 | 3 | import Frugel ( GenericAction ) 4 | import qualified Frugel 5 | import Frugel.Web.Model 6 | 7 | import Scout 8 | 9 | -- The Elm Architecture forces model changes to be centralised. Actions should describe the changes as precisely as possible given their origin 10 | data Action 11 | = Init 12 | | GenerateRandom 13 | | Log String 14 | | PrettyPrint 15 | | GenericAction GenericAction 16 | | AsyncAction AsyncAction 17 | | ChangeFocusedNodeEvaluationIndex FocusedNodeValueIndexAction 18 | | ChangeFuelLimit Int 19 | | ChangeFieldRenderDepth RenderDepthField Int 20 | | ToggleDefinitionsView 21 | | ToggleHelp 22 | | ToggleLimitEvaluationByDefault 23 | deriving ( Show, Eq ) 24 | 25 | data AsyncAction 26 | = EvaluationFinished Model 27 | | NewProgramGenerated (Frugel.Model Program) 28 | | EvaluationAborted String 29 | deriving ( Show, Eq ) 30 | 31 | data FocusedNodeValueIndexAction = Increment | Decrement 32 | deriving ( Show, Eq ) 33 | -------------------------------------------------------------------------------- /app/Frugel/Web/Event.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module Frugel.Web.Event where 11 | 12 | import Data.Aeson.Types 13 | 14 | import Frugel 15 | import Frugel.Web.Action 16 | 17 | import Miso ( Attribute, Options(..), defaultOptions, onWithOptions ) 18 | import Miso.Event.Decoder hiding ( keyInfoDecoder ) 19 | 20 | import Optics.Extra.Scout 21 | 22 | data KeyInfo 23 | = KeyInfo { key :: !String, shiftKey, metaKey, ctrlKey, altKey :: !Bool } 24 | deriving ( Show, Eq ) 25 | 26 | makeFieldLabelsNoPrefix ''KeyInfo 27 | 28 | keyDownHandler :: Attribute Action 29 | keyDownHandler = onKeyDownWithInfo handleKeyDown 30 | where 31 | handleKeyDown keyInfo@KeyInfo{..} 32 | = if noModifiers keyInfo 33 | then (case key of 34 | [c] -> GenericAction $ Insert c 35 | "Enter" -> GenericAction $ Insert '\n' 36 | "Tab" -> GenericAction $ Insert '\t' 37 | "Delete" -> GenericAction Delete 38 | "Backspace" -> GenericAction Backspace 39 | "ArrowLeft" -> GenericAction $ Move Leftward 40 | "ArrowRight" -> GenericAction $ Move Rightward 41 | "ArrowUp" -> GenericAction $ Move Upward 42 | "ArrowDown" -> GenericAction $ Move Downward 43 | _ -> Log key) 44 | else (case key of 45 | [c] | singleModifier #shiftKey keyInfo -> 46 | GenericAction $ Insert c 47 | "Enter" | singleModifier #ctrlKey keyInfo -> PrettyPrint 48 | -- Up and down also available with Alt to prevent window scrolling until https://github.com/dmjio/miso/issues/652 is fixed 49 | "ArrowUp" | singleModifier #altKey keyInfo -> 50 | GenericAction $ Move Upward 51 | "ArrowDown" | singleModifier #altKey keyInfo -> 52 | GenericAction $ Move Downward 53 | -- Left and right also allowed with Alt, because pressing/releasing Alt repeatedly while navigating is annoying 54 | "ArrowLeft" | singleModifier #altKey keyInfo -> 55 | GenericAction $ Move Leftward 56 | "ArrowRight" | singleModifier #altKey keyInfo -> 57 | GenericAction $ Move Rightward 58 | _ -> Log key) 59 | 60 | noModifiers :: KeyInfo -> Bool 61 | noModifiers KeyInfo{..} = not $ metaKey || ctrlKey || altKey || shiftKey 62 | 63 | singleModifier :: (Is k A_Setter, Is k A_Getter) 64 | => Optic k is KeyInfo KeyInfo Bool Bool 65 | -> KeyInfo 66 | -> Bool 67 | singleModifier modifier keyInfo 68 | = noModifiers (keyInfo & modifier .~ False) && view modifier keyInfo 69 | 70 | -- | https://developer.mozilla.org/en-US/docs/Web/Events/keydown 71 | onKeyDownWithInfo :: (KeyInfo -> action) -> Attribute action 72 | onKeyDownWithInfo 73 | = onWithOptions (Miso.defaultOptions { preventDefault = False }) 74 | "keydown" 75 | keyInfoDecoder 76 | 77 | keyInfoDecoder :: Decoder KeyInfo 78 | keyInfoDecoder = Decoder { .. } 79 | where 80 | decodeAt = DecodeTarget mempty 81 | decoder = withObject "event" $ \o -> KeyInfo <$> o .: "key" 82 | <*> o .: "shiftKey" 83 | <*> o .: "metaKey" 84 | <*> o .: "ctrlKey" 85 | <*> o .: "altKey" 86 | -------------------------------------------------------------------------------- /app/Frugel/Web/Internal/Model.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module Frugel.Web.Internal.Model where 11 | 12 | import Optics.Extra.Scout 13 | 14 | import Scout hiding ( EvaluationStatus ) 15 | 16 | -- It would be nicer to split the data into "editable data" that contains a version which is automatically updated, but at the moment FocusedNodeValueIndexAction and ChangeSelectedNodeValueTreeDepth are the only action where the version is updated manually 17 | data Model 18 | = Model { editableDataVersion :: Integer 19 | , evaluationStatus :: EvaluationStatus 20 | , cursorOffset :: Int 21 | , program :: Program 22 | , errors :: [Error] 23 | , showHelp :: Bool 24 | , fuelLimit :: Int 25 | , limitEvaluationByDefault :: Bool 26 | , selectedNodeEvaluationIndex :: Int 27 | , mainExpressionRenderDepth :: Int 28 | , selectedNodeValueRenderDepth :: Int 29 | , contextRenderDepth :: Int 30 | , definitionsViewCollapsed :: Bool 31 | -- evaluationOutput being last is VERY IMPORTANT, because focusedNodeEvaluations may contain non-terminating computations and (==) will not terminate if no other difference is found in any previous field 32 | -- At the moment, partiallyEvaluated also changes when evaluationOutput is set to a value that may not terminate 33 | -- Using a breadth-first implementation of Eq would be a more elegant solution 34 | , evaluationOutput :: EvaluationOutput 35 | } 36 | deriving ( Show, Eq ) 37 | 38 | data EvaluationStatus = Evaluated | PartiallyEvaluated | Aborted String 39 | deriving ( Show, Eq ) 40 | 41 | data EvaluationOutput 42 | = EvaluationOutput { evaluated :: Program 43 | , focusedNodeEvaluations :: Seq FocusedNodeEvaluation 44 | } 45 | deriving ( Show, Eq ) 46 | 47 | makeFieldLabelsNoPrefix ''Model 48 | 49 | makeFieldLabelsNoPrefix ''EvaluationOutput 50 | 51 | instance LabelOptic "selectedNodeEvaluation" An_AffineTraversal Model Model FocusedNodeEvaluation FocusedNodeEvaluation where 52 | labelOptic = atraversal matcher setter 53 | where 54 | matcher model@Model{..} 55 | = matching (selectedNodeEvaluation' selectedNodeEvaluationIndex) 56 | model 57 | setter model@Model{..} 58 | = flip (set $ selectedNodeEvaluation' selectedNodeEvaluationIndex) 59 | model 60 | selectedNodeEvaluation' i 61 | = #evaluationOutput 62 | % #focusedNodeEvaluations 63 | % (ix i `gfailing` _last) 64 | -------------------------------------------------------------------------------- /app/Frugel/Web/Model.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | 7 | module Frugel.Web.Model 8 | ( module Frugel.Web.Model 9 | , Model(Model) 10 | , EvaluationStatus(..) 11 | , EvaluationOutput(EvaluationOutput) 12 | ) where 13 | 14 | import qualified Data.MultiSet as MultiSet 15 | 16 | import qualified Frugel 17 | import Frugel.Web.Internal.Model 18 | 19 | import Optics.Extra.Scout 20 | 21 | import Scout hiding ( Evaluated, EvaluationStatus ) 22 | 23 | initialModel :: Program -> Model 24 | initialModel p 25 | = Model { editableDataVersion = 0 26 | , fuelLimit = 20 27 | , limitEvaluationByDefault = False 28 | , selectedNodeEvaluationIndex = 0 29 | , errors = [] 30 | , showHelp = True 31 | , evaluationStatus = PartiallyEvaluated 32 | , mainExpressionRenderDepth = 20 33 | , selectedNodeValueRenderDepth = 10 34 | , contextRenderDepth = 5 35 | , definitionsViewCollapsed = True 36 | , evaluationOutput 37 | = EvaluationOutput { evaluated = program' 38 | evaluationPlaceHolder 39 | Nothing 40 | , focusedNodeEvaluations = mempty 41 | } 42 | , .. 43 | } 44 | where 45 | Frugel.Model{..} 46 | = Frugel.prettyPrint -- pretty print twice, because program may not be fully parsed (and then it's only parsed but not pretty-printed) 47 | . Frugel.prettyPrint 48 | $ Frugel.initialModel p 49 | 50 | setWithFrugelModel :: Frugel.Model Program -> Model -> Model 51 | setWithFrugelModel Frugel.Model{..} 52 | Model{program = _, cursorOffset = _, errors = _, ..} 53 | = Model { editableDataVersion = editableDataVersion + 1 54 | , program 55 | , cursorOffset 56 | , errors = map fromFrugelError errors 57 | , .. 58 | } 59 | 60 | -- Assumes program terminates 61 | fromFrugelModel :: Model -> Frugel.Model Program -> IO Model 62 | fromFrugelModel = partialFromFrugelModel Infinity 63 | 64 | partialFromFrugelModel :: Limit -> Model -> Frugel.Model Program -> IO Model 65 | partialFromFrugelModel fuel 66 | Model{program = _, cursorOffset = _, errors = _, ..} 67 | Frugel.Model{..} = do 68 | (evaluated, (evalErrors, focusedNodeEvaluations)) <- runEval 69 | (Just cursorOffset) 70 | limitEvaluationByDefault 71 | fuel 72 | evalProgram 73 | program 74 | pure 75 | $ Model { editableDataVersion = editableDataVersion + 1 76 | , errors = map fromFrugelError errors 77 | ++ map (uncurry $ flip EvaluationError) 78 | (MultiSet.toOccurList evalErrors) 79 | , evaluationStatus = if limitEvaluationByDefault 80 | then Evaluated 81 | else case fuel of 82 | Only _ -> PartiallyEvaluated 83 | Infinity -> Evaluated 84 | , evaluationOutput = EvaluationOutput { .. } 85 | , .. 86 | } 87 | 88 | setFrugelErrors :: [Frugel.Error Program] -> Model -> Model 89 | setFrugelErrors newErrors 90 | = chain [ #editableDataVersion +~ 1, #errors %~ \oldErrors -> 91 | rights (map matchFrugelError oldErrors) ++ map fromFrugelError newErrors ] 92 | 93 | toFrugelModel :: Model -> Frugel.Model Program 94 | toFrugelModel Model{..} 95 | = Frugel.Model { errors = toListOf (folded % _FrugelError) errors, .. } 96 | 97 | contextInView :: Model -> Bool 98 | contextInView model = definitionsInView model || variablesInView model 99 | 100 | definitionsInView :: Model -> Bool 101 | definitionsInView model 102 | = not (view #definitionsViewCollapsed model) 103 | && has (#selectedNodeEvaluation % #definitions % folded) model 104 | 105 | variablesInView :: Model -> Bool 106 | variablesInView = has $ #selectedNodeEvaluation % #variables % folded 107 | 108 | -- force errors to force full evaluation 109 | forceMainExpression :: Model -> Model 110 | forceMainExpression model@Model{..} = seq (length errors) model 111 | 112 | forceSelectedNodeValue :: Model -> Model 113 | forceSelectedNodeValue = forceSelectedNodeField SelectedNodeValue #value 114 | 115 | forceSelectedNodeContext :: Model -> Model 116 | forceSelectedNodeContext model 117 | = applyWhen (not $ view #definitionsViewCollapsed model) 118 | forceSelectedNodeDefinitions 119 | $ forceSelectedNodeVariables model 120 | 121 | forceSelectedNodeDefinitions :: Model -> Model 122 | forceSelectedNodeDefinitions 123 | = forceSelectedNodeField SelectedNodeContext 124 | $ #definitions % folded % to ExprNode 125 | 126 | forceSelectedNodeVariables :: Model -> Model 127 | forceSelectedNodeVariables 128 | = forceSelectedNodeField SelectedNodeContext 129 | $ #variables % folded % to ExprNode 130 | 131 | forceSelectedNodeField :: Is k A_Fold 132 | => RenderDepthField 133 | -> Optic' k is FocusedNodeEvaluation Node 134 | -> Model 135 | -> Model 136 | forceSelectedNodeField field fieldNodes model 137 | = seq (lengthOf (#selectedNodeEvaluation 138 | % castOptic @A_Fold fieldNodes 139 | % to (truncate $ view (renderDepthFieldLens field) model) 140 | % allEvaluatedChildren) 141 | model) 142 | model 143 | 144 | hideMainExpression :: Model -> Model 145 | hideMainExpression 146 | = hideEvaluationOutputField $ #evaluationOutput % #evaluated % #expr 147 | 148 | hideSelectedNodeEvaluation :: Model -> Model 149 | hideSelectedNodeEvaluation = hideSelectedNodeValue . hideSelectedNodeContext 150 | 151 | hideSelectedNodeValue :: Model -> Model 152 | hideSelectedNodeValue 153 | = hideEvaluationOutputField $ #selectedNodeEvaluation % #value % _ExprNode 154 | 155 | hideSelectedNodeContext :: Model -> Model 156 | hideSelectedNodeContext 157 | = hideSelectedNodeDefinitions . hideSelectedNodeVariables 158 | 159 | hideSelectedNodeDefinitions :: Model -> Model 160 | hideSelectedNodeDefinitions 161 | = hideEvaluationOutputField 162 | $ #selectedNodeEvaluation % #definitions % traversed 163 | 164 | hideSelectedNodeVariables :: Model -> Model 165 | hideSelectedNodeVariables 166 | = hideEvaluationOutputField 167 | $ #selectedNodeEvaluation % #variables % traversed 168 | 169 | hideEvaluationOutputField 170 | :: Is k A_Traversal => Optic' k is Model Expr -> Model -> Model 171 | hideEvaluationOutputField (castOptic @A_Traversal -> fieldNodes) model 172 | = model 173 | & fieldNodes .~ evaluationPlaceHolder 174 | & #evaluationStatus 175 | .~ if has fieldNodes model then PartiallyEvaluated else Evaluated 176 | 177 | evaluationPlaceHolder :: Expr 178 | evaluationPlaceHolder = exprCstrSite' . toCstrSite . one $ Left "Evaluating..." 179 | 180 | data RenderDepthField 181 | = MainExpression | SelectedNodeValue | SelectedNodeContext 182 | deriving ( Show, Eq ) 183 | 184 | renderDepthFieldLens :: RenderDepthField -> Lens' Model Int 185 | renderDepthFieldLens MainExpression = #mainExpressionRenderDepth 186 | renderDepthFieldLens SelectedNodeValue = #selectedNodeValueRenderDepth 187 | renderDepthFieldLens SelectedNodeContext = #contextRenderDepth 188 | 189 | forceFieldValues :: RenderDepthField -> Model -> Model 190 | forceFieldValues MainExpression = forceMainExpression 191 | forceFieldValues SelectedNodeValue = forceSelectedNodeValue 192 | forceFieldValues SelectedNodeContext = forceSelectedNodeContext 193 | 194 | hideFieldValues :: RenderDepthField -> Model -> Model 195 | hideFieldValues MainExpression = hideMainExpression 196 | hideFieldValues SelectedNodeValue = hideSelectedNodeValue 197 | hideFieldValues SelectedNodeContext = hideSelectedNodeContext 198 | -------------------------------------------------------------------------------- /app/Frugel/Web/View/Elements.hs: -------------------------------------------------------------------------------- 1 | module Frugel.Web.View.Elements where 2 | 3 | import Frugel.Web.Action 4 | import Frugel.Web.Event 5 | 6 | import Miso 7 | 8 | codeSpan :: [Attribute action] -> [View action] -> View action 9 | codeSpan = span_ . (class_ "code-span" :) 10 | 11 | inConstruction :: [Attribute action] -> [View action] -> View action 12 | inConstruction = codeSpan . (class_ "in-construction node-padding" :) 13 | 14 | complete :: [Attribute action] -> [View action] -> View action 15 | complete = codeSpan . (class_ "has-background-white node-padding" :) 16 | 17 | elided :: [Attribute action] -> [View action] -> View action 18 | elided = codeSpan . (class_ "elided" :) 19 | 20 | -- node :: [Attribute action] -> [View action] -> View action 21 | -- node = codeSpan . (class_ "node" :) 22 | caret :: [Attribute action] -> [View action] -> View action 23 | caret = codeSpan . (class_ "caret" :) 24 | 25 | codeRoot :: [Attribute Action] -> [View Action] -> View Action 26 | codeRoot 27 | = button_ -- Using a button, because only (some) elements generate events 28 | . (++ [ keyDownHandler 29 | , id_ "code-root" 30 | , class_ "block no-button-style code-root" 31 | ]) 32 | 33 | line :: [Attribute action] -> [View action] -> View action 34 | line = div_ . (class_ "line" :) 35 | -------------------------------------------------------------------------------- /app/Frugel/Web/View/Rendering.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Frugel.Web.View.Rendering where 5 | 6 | import Frugel 7 | import Frugel.Web.View.Elements as Elements 8 | 9 | import Miso hiding ( Node, node, view ) 10 | import qualified Miso.String 11 | 12 | import Optics.Extra.Scout hiding ( views ) 13 | 14 | import Prelude hiding ( lines ) 15 | 16 | import Prettyprinter.Render.Util.SimpleDocTree 17 | 18 | import Scout.PrettyPrinting 19 | 20 | data DocTextTree 21 | = TextLeaf Text | LineLeaf | Annotated Annotation [DocTextTree] 22 | deriving ( Show, Eq ) 23 | 24 | data AnnotationTree = Leaf Text | Node Annotation [AnnotationTree] 25 | deriving ( Show, Eq ) 26 | 27 | newtype Line = Line [AnnotationTree] 28 | deriving ( Show, Eq ) 29 | 30 | makePrisms ''DocTextTree 31 | 32 | makePrisms ''Line 33 | 34 | isEmptyTree :: DocTextTree -> Bool 35 | isEmptyTree = \case 36 | TextLeaf "" -> True 37 | Annotated Cursor _ -> False 38 | Annotated (CompletionAnnotation InConstruction) _ -> False 39 | Annotated _ [] -> True 40 | Annotated _ trees -> all isEmptyTree trees 41 | _ -> False 42 | 43 | renderPretty :: AnnotatedPretty a => a -> [View action] 44 | renderPretty 45 | = renderDocStream 46 | . reAnnotateS toStandardAnnotation 47 | . layoutPretty defaultLayoutOptions 48 | . annPretty 49 | 50 | -- instead of rendering to a SimpleDocStream and converting back to a tree with `treeForm`, `renderDoc` could be made to produce DocTextTree's directly, which would speed up rendering a bit 51 | -- it would also be simpler (and probably faster) to intersperse additional SAnnPop's and SAnnPush's around SLine's using a renderFunction which counts annotation levels instead of what `splitMultiLineAnnotations` does 52 | renderDocStream :: SimpleDocStream Annotation -> [View action] 53 | renderDocStream 54 | = renderTrees 55 | . annotationTreeForm 56 | . splitMultiLineAnnotations 57 | . textLeavesConcat 58 | . textTreeForm 59 | . treeForm 60 | 61 | textTreeForm :: SimpleDocTree Annotation -> [DocTextTree] 62 | textTreeForm = \case 63 | STEmpty -> [] 64 | STChar '\n' -> one LineLeaf -- Normally, there would be no newlines in STChar, but these are explicitly inserted by renderCstrSite' to prevent insertion of extra whitespace when pretty printing construction sites which are `nest`ed 65 | STChar c -> one . TextLeaf $ one c 66 | STText _ t -> one $ TextLeaf t 67 | STLine w -> LineLeaf : [ TextLeaf . toText $ replicate w ' ' | w > 0 ] 68 | STAnn ann content -> one . Annotated ann $ textTreeForm content 69 | STConcat contents -> concatMap textTreeForm contents 70 | 71 | -- for some reason eta-reduction here causes an "Unexpected lambda in case" 72 | textLeavesConcat :: [DocTextTree] -> [DocTextTree] 73 | textLeavesConcat trees 74 | = over (mapped % _Annotated % _2) textLeavesConcat 75 | $ concatByPrism _TextLeaf trees 76 | 77 | splitMultiLineAnnotations :: [DocTextTree] -> [DocTextTree] 78 | splitMultiLineAnnotations = foldMap $ \case 79 | TextLeaf t -> [ TextLeaf t ] 80 | LineLeaf -> [ LineLeaf ] 81 | Annotated Cursor _ -> [ Annotated Cursor [] ] 82 | Annotated (Frugel.CompletionAnnotation completionStatus) trees -> filter 83 | (not . isEmptyTree) 84 | . intersperse LineLeaf 85 | . reAnnotateTrees completionStatus 86 | . splitOn LineLeaf 87 | $ splitMultiLineAnnotations trees 88 | tree@(Annotated Elided _) -> [ tree ] 89 | where 90 | reAnnotateTrees completionStatus ((firstLine :< middleLines) :> lastLine) 91 | = reannotate firstLine 92 | <| (map reannotate middleLines |> reannotate lastLine) 93 | where 94 | reannotate = Annotated $ CompletionAnnotation completionStatus 95 | reAnnotateTrees completionStatus treeLines 96 | = map (Annotated $ CompletionAnnotation completionStatus) treeLines -- length treeLines <= 1 97 | 98 | annotationTreeForm :: [DocTextTree] -> [Line] 99 | annotationTreeForm = map (Line . map transform) . splitOn LineLeaf 100 | where 101 | transform = \case 102 | TextLeaf t -> Leaf t 103 | LineLeaf -> error "unexpected LineLeaf" 104 | Annotated ann trees -> Node ann $ map transform trees 105 | 106 | renderTrees :: [Line] -> [View action] 107 | renderTrees = map (Elements.line [] . map renderTree . view _Line) 108 | 109 | renderTree :: AnnotationTree -> View action 110 | renderTree = \case 111 | Leaf t -> text $ Miso.String.ms t -- ms required on GHCJS 112 | Node annotation@(CompletionAnnotation InConstruction) [] -> 113 | renderTree $ Node annotation [ Leaf " " ] -- Ghost space instead of messing with CSS 114 | Node annotation subTrees -> 115 | encloseInTagFor annotation $ map renderTree subTrees 116 | 117 | encloseInTagFor :: Annotation -> [View action] -> View action 118 | encloseInTagFor ann views = case ann of 119 | CompletionAnnotation InConstruction -> inConstruction [] views 120 | CompletionAnnotation Complete -> complete [] views 121 | Cursor -> caret [] [] 122 | Elided -> elided [] views 123 | -------------------------------------------------------------------------------- /app/Language/Javascript/JSaddle/Warp/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | module Language.Javascript.JSaddle.Warp.Extra where 5 | 6 | #ifndef ghcjs_HOST_OS 7 | import Language.Javascript.JSaddle.Run ( syncPoint ) 8 | import Language.Javascript.JSaddle.Types ( JSM ) 9 | import Language.Javascript.JSaddle.WebSockets hiding ( debug ) 10 | 11 | import Miso.Dev ( clearBody ) 12 | 13 | import qualified Network.Wai.Application.Static as WaiStatic 14 | import qualified Network.Wai.Handler.Warp as Warp 15 | import Network.WebSockets as WS 16 | 17 | import Paths_frugel 18 | 19 | import System.Directory 20 | import System.Environment 21 | import System.FilePath 22 | #endif 23 | 24 | -- Split if to make floskell work 25 | 26 | #ifndef ghcjs_HOST_OS 27 | debug :: Int -> FilePath -> JSM () -> IO () 28 | debug port dir f = do 29 | let staticApp 30 | = WaiStatic.staticApp $ WaiStatic.defaultFileServerSettings dir 31 | debugWrapper $ \withRefresh registerContext -> Warp.runSettings 32 | (Warp.setPort port $ Warp.setTimeout 3600 Warp.defaultSettings) 33 | =<< jsaddleOr 34 | defaultConnectionOptions 35 | (registerContext >> clearBody >> f >> syncPoint) 36 | (withRefresh $ jsaddleAppWithJsOr (jsaddleJs True) staticApp) 37 | putStrLn $ "http://localhost:" <> show port 38 | 39 | runApp :: JSM () -> IO () 40 | runApp app = do 41 | dataDir <- do 42 | firstExistingDataDir <- foldr 43 | (\getDir acc -> getDir >>= \dir -> 44 | ifM (doesPathExist dir) (pure $ Just dir) acc) 45 | (pure Nothing) 46 | dataDirs 47 | maybe ("" <$ print @String "Failed to find web root") 48 | pure 49 | firstExistingDataDir 50 | debug 3708 dataDir app 51 | where 52 | dataDirs = [pure "www", getDataDir, do 53 | exePath <- getExecutablePath 54 | binDir <- getBinDir 55 | dataDir <- getDataDir 56 | pure 57 | $ takeDirectory (takeDirectory exePath) 58 | makeRelative (takeDirectory binDir) dataDir ] 59 | 60 | #else 61 | runApp :: IO () -> IO () 62 | runApp = id 63 | #endif 64 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE MultiWayIf #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | 8 | module Main where 9 | 10 | import Control.Concurrent 11 | import Control.Exception 12 | import Control.Timeout 13 | import Control.ValidEnumerable 14 | 15 | import qualified Data.Sequence as Seq 16 | import Data.Sized 17 | 18 | import Frugel 19 | hiding ( Model, initialModel, updateModel ) 20 | import qualified Frugel 21 | import Frugel.Web.Action 22 | import qualified Frugel.Web.Internal.Model 23 | import Frugel.Web.Model 24 | import Frugel.Web.View 25 | 26 | import Language.Javascript.JSaddle.Warp.Extra as JSaddleWarp 27 | 28 | import Miso hiding ( model, node, set, view ) 29 | import qualified Miso 30 | 31 | import Optics.Extra.Scout 32 | 33 | import Scout hiding ( Evaluated ) 34 | 35 | import Test.QuickCheck.Gen 36 | 37 | main :: IO () 38 | main = do 39 | evalThreadVar <- liftIO $ newMVar Nothing 40 | -- sadly, handling heap overflows does not work when running in GHCi (because this is not run on the main thread which receives the exception) 41 | let handleHeapOverflow e = do 42 | foldMap (flip throwTo e . fst) =<< swapMVar evalThreadVar Nothing 43 | catchHeapOverflow $ void getLine 44 | catchHeapOverflow action 45 | = catchJust (guarded (== HeapOverflow)) action handleHeapOverflow 46 | catchHeapOverflow $ do 47 | runApp 48 | $ startApp App { initialAction = Init 49 | , model = initialModel $ programCstrSite' factorial 50 | , update = updateModel evalThreadVar 51 | , view = viewApp 52 | , events = defaultEvents 53 | , subs = [] 54 | , mountPoint = Nothing 55 | , logLevel = Off 56 | } 57 | void getLine 58 | 59 | updateModel :: MVar (Maybe (ThreadId, Integer)) 60 | -> Action 61 | -> Model 62 | -> Effect Action Model 63 | updateModel evalThreadVar Init model = effectSub model $ \sink -> do 64 | focus "code-root" 65 | liftIO 66 | $ reEvaluate evalThreadVar 67 | (toFrugelModel model) 68 | (model & #editableDataVersion -~ 1) 69 | sink 70 | updateModel _ ToggleHelp model = noEff $ #showHelp %~ not $ model 71 | updateModel evalThreadVar GenerateRandom model 72 | = effectSub model $ \sink -> liftIO $ do 73 | newProgram <- unSized @500 <.> generate $ uniformValid 500 74 | let newFrugelModel 75 | = set #cursorOffset 0 76 | . snd 77 | . attemptEdit (const $ Right newProgram) -- reparse the new program for parse errors 78 | $ toFrugelModel model 79 | sink . AsyncAction $ NewProgramGenerated newFrugelModel 80 | reEvaluate evalThreadVar newFrugelModel model sink 81 | updateModel _ (Log msg) model = effectSub model . const . consoleLog $ show msg 82 | updateModel evalThreadVar ToggleLimitEvaluationByDefault model 83 | = reEvaluateModel evalThreadVar $ #limitEvaluationByDefault %~ not $ model 84 | updateModel evalThreadVar (ChangeFocusedNodeEvaluationIndex indexAction) model 85 | = effectSub (hideSelectedNodeEvaluation newModel) $ \sink -> liftIO 86 | . bracketNonTermination (view #editableDataVersion newModel) evalThreadVar 87 | . yieldWithForcedSelectedNodeEvaluation sink 88 | $ #evaluationStatus .~ Evaluated 89 | $ newModel 90 | where 91 | newModel 92 | = model 93 | & #editableDataVersion +~ 1 94 | & #selectedNodeEvaluationIndex %~ case indexAction of 95 | Increment -> min (focusNodeValuesCount - 1) . succ 96 | Decrement -> max 0 . pred . min (focusNodeValuesCount - 1) 97 | focusNodeValuesCount 98 | = Seq.length $ view (#evaluationOutput % #focusedNodeEvaluations) model 99 | updateModel evalThreadVar 100 | (ChangeFieldRenderDepth field newDepth) 101 | model@Model{..} 102 | = if limitEvaluationByDefault 103 | then noEff $ renderDepthFieldLens field .~ newDepth $ model 104 | else effectSub 105 | (hideFieldValues field newModel & #editableDataVersion +~ 1) 106 | $ \sink -> liftIO 107 | . bracketNonTermination (view #editableDataVersion model + 1) 108 | evalThreadVar 109 | $ do 110 | -- Instead of reevaluating here, it would be more efficient to find and append the extra errors the deeper evaluation produces 111 | reEvaluatedModel 112 | <- fromFrugelModel newModel (toFrugelModel model) 113 | yieldModel sink $ forceFieldValues field reEvaluatedModel 114 | where 115 | newModel = model & renderDepthFieldLens field .~ newDepth 116 | updateModel evalThreadVar (ChangeFuelLimit newLimit) model 117 | = reEvaluateModel evalThreadVar $ #fuelLimit .~ max 0 newLimit $ model 118 | -- reEvaluate to type error locations 119 | updateModel evalThreadVar PrettyPrint model 120 | = reEvaluateFrugelModel evalThreadVar 121 | (prettyPrint $ toFrugelModel model) 122 | model 123 | updateModel evalThreadVar ToggleDefinitionsView model 124 | = if view #definitionsViewCollapsed model 125 | then effectSub (hideSelectedNodeDefinitions newModel) $ \sink -> liftIO 126 | . bracketNonTermination (view #editableDataVersion newModel) 127 | evalThreadVar 128 | . yieldModel sink 129 | . forceSelectedNodeDefinitions 130 | $ #evaluationStatus .~ Evaluated 131 | $ newModel 132 | else noEff newModel 133 | where 134 | newModel 135 | = model & #editableDataVersion +~ 1 & #definitionsViewCollapsed %~ not 136 | -- Move action also causes reEvaluation, because value of expression under the cursor may need to be updated 137 | updateModel evalThreadVar (GenericAction genericAction) model 138 | = case editResult of 139 | Success -> reEvaluateFrugelModel evalThreadVar newFrugelModel model 140 | Failure -> noEff $ setFrugelErrors (view #errors newFrugelModel) model 141 | where 142 | (editResult, newFrugelModel) 143 | = Frugel.updateModel genericAction $ toFrugelModel model 144 | updateModel _ (AsyncAction asyncAction) model = case asyncAction of 145 | EvaluationFinished newModel -> if view #editableDataVersion newModel 146 | == view #editableDataVersion model 147 | then noEff newModel 148 | else effectSub model . const $ pure () 149 | NewProgramGenerated frugelModel -> 150 | noEff $ setWithFrugelModel frugelModel model 151 | EvaluationAborted msg -> noEff $ #evaluationStatus .~ Aborted msg $ model 152 | 153 | reEvaluateModel 154 | :: MVar (Maybe (ThreadId, Integer)) -> Model -> Effect Action Model 155 | reEvaluateModel evalThreadVar model 156 | = reEvaluateFrugelModel evalThreadVar (toFrugelModel model) model 157 | 158 | reEvaluateFrugelModel :: MVar (Maybe (ThreadId, Integer)) 159 | -> Frugel.Model Program 160 | -> Model 161 | -> Effect Action Model 162 | reEvaluateFrugelModel evalThreadVar frugelModel model 163 | = effectSub (set #evaluationStatus PartiallyEvaluated 164 | $ setWithFrugelModel frugelModel model) 165 | . (liftIO .) 166 | $ reEvaluate evalThreadVar frugelModel model 167 | 168 | reEvaluate :: MVar (Maybe (ThreadId, Integer)) 169 | -> Frugel.Model Program 170 | -> Model 171 | -> Sink Action 172 | -> IO () 173 | reEvaluate 174 | evalThreadVar 175 | newFrugelModel 176 | model@Model{fuelLimit, editableDataVersion, limitEvaluationByDefault} 177 | sink 178 | = bracketNonTermination (succ editableDataVersion) evalThreadVar 179 | $ if limitEvaluationByDefault 180 | then reportExceptions 181 | $ yieldWithForcedMainExpression sink =<< partialModel 182 | else unlessFinishedIn 183 | 500000 -- half a second 184 | (yieldWithForcedMainExpression sink =<< partialModel) 185 | . cancelPartialEvaluationOnException 186 | $ reportExceptions (yieldWithForcedMainExpression sink 187 | =<< fromFrugelModel model newFrugelModel) 188 | where 189 | partialModel = partialFromFrugelModel (Only fuelLimit) model newFrugelModel 190 | reportExceptions action 191 | = catch action (\(e :: SomeException) -> do 192 | sink $ AsyncAction $ EvaluationAborted $ show e 193 | throwIO e) 194 | cancelPartialEvaluationOnException action partialThreadVar 195 | = catch action (\(e :: SomeException) -> do 196 | void . traverse killThread 197 | =<< tryReadMVar partialThreadVar 198 | throwIO e) 199 | 200 | yieldWithForcedMainExpression :: Sink Action -> Model -> IO () 201 | yieldWithForcedMainExpression sink newModel 202 | = if hasn't #selectedNodeEvaluation newModel 203 | then yieldModel sink $ forceMainExpression newModel 204 | else do 205 | yieldModel sink . forceMainExpression 206 | $ hideSelectedNodeEvaluation newModel 207 | yieldWithForcedSelectedNodeEvaluation sink newModel 208 | 209 | -- force selected node evaluation separately because evaluation up to a certain depth may encounter non-terminating expressions that were not evaluated in the evaluation of the top expression 210 | yieldWithForcedSelectedNodeEvaluation :: Sink Action -> Model -> IO () 211 | yieldWithForcedSelectedNodeEvaluation sink newModel 212 | = if not (contextInView newModel) 213 | then yieldModel sink $ forceSelectedNodeValue newModel 214 | else do 215 | yieldModel sink 216 | $ forceSelectedNodeValue 217 | $ hideSelectedNodeContext newModel 218 | yieldWithForcedSelectedNodeContext sink newModel 219 | 220 | yieldWithForcedSelectedNodeContext :: Sink Action -> Model -> IO () 221 | yieldWithForcedSelectedNodeContext sink newModel 222 | = if | not $ definitionsInView newModel -> 223 | yieldModel sink $ forceSelectedNodeVariables newModel 224 | | not $ variablesInView newModel -> 225 | yieldModel sink $ forceSelectedNodeDefinitions newModel 226 | | otherwise -> do 227 | yieldModel sink . forceSelectedNodeDefinitions 228 | $ hideSelectedNodeVariables newModel 229 | yieldModel sink $ forceSelectedNodeVariables newModel 230 | 231 | bracketNonTermination 232 | :: Integer -> MVar (Maybe (ThreadId, Integer)) -> IO () -> IO () 233 | bracketNonTermination version evalThreadVar action = do 234 | threadId <- myThreadId 235 | outdated <- modifyMVar evalThreadVar $ \v -> case v of 236 | Just (runningId, runningVersion) 237 | | version > runningVersion -> 238 | (Just (threadId, version), False) <$ killThread runningId 239 | Just _ -> pure (v, True) 240 | Nothing -> pure (Just (threadId, version), False) 241 | unless outdated $ do 242 | u <- action 243 | void $ swapMVar evalThreadVar $! seq u Nothing 244 | 245 | -- yieldModel is strict in the model to make sure evaluation happens in the update thread instead of in the view thread 246 | yieldModel :: Sink Action -> Model -> IO () 247 | yieldModel sink model = sink . AsyncAction . EvaluationFinished $! model 248 | -------------------------------------------------------------------------------- /base.nix: -------------------------------------------------------------------------------- 1 | { pkgs, ghc }: 2 | let 3 | fetchpatch = pkgs.fetchpatch; 4 | callHpack = name: src: pkgs.runCommand "hpack2cabal-${name}" { } '' 5 | mkdir -p $out 6 | cp -r ${src}/. $out/ 7 | rm "$out/frugel.cabal" 8 | ${pkgs.hpack}/bin/hpack '${src}' - > "$out/frugel.cabal" 9 | ''; 10 | in 11 | pkgs.haskell-nix.cabalProject { 12 | src = callHpack "frugel" ( 13 | pkgs.haskell-nix.haskellLib.cleanGit { 14 | name = "frugel"; 15 | src = ./.; 16 | } 17 | ); 18 | compiler-nix-name = ghc; 19 | modules = [ 20 | { 21 | packages.miso.patches = [ 22 | ( 23 | ( 24 | fetchpatch { 25 | name = "prevent-firefox-spinning-xhr.patch"; 26 | url = "https://github.com/cdfa/miso/commit/4e1a6ee7c18a63a501ffaf08227011181e427b1a.patch"; 27 | sha256 = "185mxvmdg3x7vpdw800w0lqj2via2z8snb9wys015bv1y1yi5q2i"; 28 | } 29 | ) 30 | ) 31 | ]; 32 | } 33 | { 34 | packages.frugel.components.exes.frugel-exe.configureFlags = 35 | pkgs.lib.optionals pkgs.stdenv.hostPlatform.isMusl [ 36 | "--disable-executable-dynamic" 37 | "--disable-shared" 38 | "--ghc-option=-optl=-pthread" 39 | "--ghc-option=-optl=-static" 40 | "--ghc-option=-optl=-L${pkgs.gmp6.override { withStatic = true; }}/lib" 41 | "--ghc-option=-optl=-L${pkgs.zlib.static}/lib" 42 | ]; 43 | } 44 | ]; 45 | } 46 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | index-state: 2021-12-02T00:00:00Z 4 | 5 | allow-newer: size-based:template-haskell, base-noprelude:base 6 | 7 | allow-older: base-noprelude-ghcjs:base 8 | 9 | source-repository-package 10 | type: git 11 | location: https://github.com/cdfa/base-noprelude-ghcjs 12 | tag: 0cd2afc636928b29a196fb86be6cc8272c486c49 13 | --sha256: 1isya3qds75f9dbm1p2wkxkr8z1jzjxi5j800bnskk36nvk2avfm 14 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { sources ? import ./nix/sources.nix { } 2 | , ghc ? "ghc8107" 3 | }: 4 | let 5 | haskellNix = import sources.haskellNix { }; 6 | pkgs = import haskellNix.sources.nixpkgs-unstable haskellNix.nixpkgsArgs; 7 | hsPkgs = import ./base.nix { inherit pkgs ghc; }; 8 | frugel-cross = { platform }: hsPkgs.projectCross.${platform}.hsPkgs.frugel.components.exes.frugel-exe; 9 | in 10 | { 11 | frugel-web = pkgs.stdenv.mkDerivation { 12 | name = "frugel-web"; 13 | src = pkgs.haskell-nix.haskellLib.cleanGit { 14 | name = "frugel"; 15 | src = ./.; 16 | subDir = "www"; 17 | }; 18 | buildInputs = [ pkgs.closurecompiler ]; 19 | installPhase = '' 20 | mkdir -p $out 21 | find . \( -name '*.html' -o -name '*.css' \) -exec cp {} $out \; 22 | FRUGEL_WEB=${frugel-cross { platform = "ghcjs"; }}/bin/frugel-exe.jsexe 23 | closure-compiler \ 24 | $FRUGEL_WEB/all.js --externs $FRUGEL_WEB/all.js.externs \ 25 | -O ADVANCED --jscomp_off=checkVars -W QUIET \ 26 | --js_output_file $out/all.min.js 27 | ''; 28 | }; 29 | frugel-static = frugel-cross { platform = "musl64"; }; 30 | frugel-exe = hsPkgs.frugel.components.exes.frugel-exe; 31 | # frugel-aarch64-darwin = frugel-cross { platform = "aarch64-darwin"; }; Not working due to https://github.com/NixOS/nixpkgs/issues/49526 32 | # frugel-mingwW64 = frugel-cross { platform = "mingwW64"; }; Not working due to https://github.com/NixOS/nixpkgs/issues/36200 33 | } 34 | -------------------------------------------------------------------------------- /floskell.json: -------------------------------------------------------------------------------- 1 | { 2 | "style": "cramer", 3 | "extensions": ["OverloadedLabels"], 4 | "fixities": ["infixr 8 .:.", "infixr 9 #.", "infixr 8 .#"], 5 | "formatting": { 6 | "op": { 7 | ",": { 8 | "force-linebreak": false, 9 | "spaces": "after", 10 | "linebreaks": "before" 11 | }, 12 | "=": { 13 | "force-linebreak": false, 14 | "spaces": "both", 15 | "linebreaks": "before" 16 | }, 17 | "@": { 18 | "force-linebreak": false, 19 | "spaces": "none", 20 | "linebreaks": "none" 21 | }, 22 | "default": { 23 | "force-linebreak": false, 24 | "spaces": "both", 25 | "linebreaks": "before" 26 | }, 27 | "-> in expression": { 28 | "force-linebreak": false, 29 | "spaces": "both", 30 | "linebreaks": "after" 31 | }, 32 | ". in type": { 33 | "force-linebreak": false, 34 | "spaces": "after", 35 | "linebreaks": "after" 36 | }, 37 | "$": { 38 | "force-linebreak": false, 39 | "spaces": "both", 40 | "linebreaks": "before" 41 | }, 42 | "record in pattern": { 43 | "force-linebreak": false, 44 | "spaces": "none", 45 | "linebreaks": "none" 46 | }, 47 | "record": { 48 | "force-linebreak": false, 49 | "spaces": "after", 50 | "linebreaks": "none" 51 | } 52 | }, 53 | "group": { 54 | "$(": { 55 | "force-linebreak": false, 56 | "spaces": "none", 57 | "linebreaks": "none" 58 | }, 59 | "[ in pattern": { 60 | "force-linebreak": false, 61 | "spaces": "none", 62 | "linebreaks": "after" 63 | }, 64 | "[p|": { 65 | "force-linebreak": false, 66 | "spaces": "none", 67 | "linebreaks": "none" 68 | }, 69 | "default": { 70 | "force-linebreak": false, 71 | "spaces": "both", 72 | "linebreaks": "after" 73 | }, 74 | "( in other": { 75 | "force-linebreak": false, 76 | "spaces": "both", 77 | "linebreaks": "after" 78 | }, 79 | "[ in type": { 80 | "force-linebreak": false, 81 | "spaces": "none", 82 | "linebreaks": "none" 83 | }, 84 | "[|": { 85 | "force-linebreak": false, 86 | "spaces": "none", 87 | "linebreaks": "none" 88 | }, 89 | "* in type": { 90 | "force-linebreak": false, 91 | "spaces": "none", 92 | "linebreaks": "after" 93 | }, 94 | "* in pattern": { 95 | "force-linebreak": false, 96 | "spaces": "none", 97 | "linebreaks": "after" 98 | }, 99 | "(": { 100 | "force-linebreak": false, 101 | "spaces": "none", 102 | "linebreaks": "after" 103 | }, 104 | "[d|": { 105 | "force-linebreak": false, 106 | "spaces": "none", 107 | "linebreaks": "none" 108 | }, 109 | "[t|": { 110 | "force-linebreak": false, 111 | "spaces": "none", 112 | "linebreaks": "none" 113 | } 114 | }, 115 | "layout": { 116 | "infix-app": "try-oneline", 117 | "if": "try-oneline", 118 | "import-spec-list": "flex", 119 | "con-decls": "try-oneline", 120 | "declaration": "try-oneline", 121 | "app": "try-oneline", 122 | "let": "try-oneline", 123 | "record": "try-oneline", 124 | "type": "try-oneline", 125 | "export-spec-list": "try-oneline", 126 | "list-comp": "try-oneline" 127 | }, 128 | "penalty": { 129 | "overfull": 10, 130 | "indent": 1, 131 | "overfull-once": 200, 132 | "max-line-length": 80, 133 | "linebreak": 100 134 | }, 135 | "indent": { 136 | "deriving": 4, 137 | "if": "align-or-indent-by 4", 138 | "let-binds": "align-or-indent-by 4", 139 | "import-spec-list": "align-or-indent-by 4", 140 | "onside": 4, 141 | "where": 2, 142 | "typesig": "align-or-indent-by 4", 143 | "do": "indent-by 4", 144 | "app": "align-or-indent-by 4", 145 | "case": "indent-by 4", 146 | "let-in": "align-or-indent-by 4", 147 | "where-binds": "indent-by 2", 148 | "let": "align-or-indent-by 4", 149 | "export-spec-list": "indent-by 4", 150 | "multi-if": "align-or-indent-by 4", 151 | "class": "indent-by 4" 152 | }, 153 | "align": { 154 | "let-binds": false, 155 | "where": false, 156 | "matches": false, 157 | "limits": [ 158 | 10, 159 | 25 160 | ], 161 | "case": false, 162 | "import-module": false, 163 | "import-spec": true, 164 | "class": false, 165 | "record-fields": false 166 | }, 167 | "options": { 168 | "sort-pragmas": true, 169 | "flexible-oneline": true, 170 | "decl-no-blank-lines": ["where", "instance", "class"], 171 | "split-language-pragmas": true, 172 | "align-sum-type-decl": false, 173 | "sort-import-lists": true, 174 | "preserve-vertical-space": true, 175 | "sort-imports": true 176 | } 177 | }, 178 | "language": "Haskell2010" 179 | } 180 | -------------------------------------------------------------------------------- /frugel.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.0 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.4. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: frugel 8 | version: 0.0.2.0 9 | description: An Error-tolerant Live Programming Environment 10 | homepage: https://github.com/cdfa/frugel#readme 11 | bug-reports: https://github.com/cdfa/frugel/issues 12 | author: Colin de Roos 13 | maintainer: colinderoos[at]gmail[dot]com 14 | copyright: 2021 Colin de Roos 15 | license: GPL-3 16 | build-type: Simple 17 | extra-source-files: 18 | README.md 19 | data-files: 20 | bulma.min.css 21 | style.css 22 | index.html 23 | data-dir: www 24 | 25 | source-repository head 26 | type: git 27 | location: https://github.com/cdfa/frugel 28 | 29 | library 30 | exposed-modules: 31 | Control.Zipper.Seq 32 | Frugel 33 | Frugel.Action 34 | Frugel.CstrSite 35 | Frugel.Decomposition 36 | Frugel.DisplayProjection 37 | Frugel.Error 38 | Frugel.Error.InternalError 39 | Frugel.Internal.DecompositionState 40 | Frugel.Internal.Model 41 | Frugel.Model 42 | Frugel.Parsing 43 | Frugel.PrettyPrinting 44 | Optics.Extra.Frugel 45 | other-modules: 46 | Prelude 47 | hs-source-dirs: 48 | prelude 49 | src 50 | default-extensions: 51 | OverloadedStrings 52 | OverloadedLabels 53 | DisambiguateRecordFields 54 | DeriveGeneric 55 | ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat -Widentities -Wredundant-constraints -fhide-source-paths -fno-show-valid-hole-fits -j 56 | build-depends: 57 | composition 58 | , lens 59 | , mtl 60 | , optics ==0.4.* 61 | , optics-vl >=0.2.1 && <0.3 62 | , prettyprinter >=1.7.0 && <1.8 63 | , relude >=1.0.0.0 64 | if impl(ghcjs) 65 | build-depends: 66 | base-noprelude-ghcjs >=4.7 && <5 67 | else 68 | build-depends: 69 | base-noprelude >=4.7 && <5 70 | default-language: Haskell2010 71 | 72 | library scout 73 | exposed-modules: 74 | Control.Enumerable.Combinators 75 | Control.Limited 76 | Control.ValidEnumerable 77 | Control.ValidEnumerable.Access 78 | Control.ValidEnumerable.Class 79 | Data.Alphanumeric 80 | Data.Constrained 81 | Data.Hidden 82 | Data.Sized 83 | Data.Validity.Extra 84 | Data.Whitespace 85 | Frugel.CstrSite.ValidEnumerable 86 | Optics.Extra.Scout 87 | Optics.Fallible 88 | Optics.ReadOnly.FunctorOptic 89 | Optics.ReadOnly.Intro 90 | Optics.ReadOnly.VL 91 | Optics.Writer 92 | PrettyPrinting.Expr 93 | Scout 94 | Scout.Error 95 | Scout.Evaluation 96 | Scout.Internal.EvaluationEnv 97 | Scout.Internal.Node 98 | Scout.Internal.Program 99 | Scout.Lexing 100 | Scout.Node 101 | Scout.Operators 102 | Scout.Orphans.DisplayProjection 103 | Scout.Orphans.MultiSet 104 | Scout.Orphans.Stream 105 | Scout.Parsing 106 | Scout.Parsing.Error 107 | Scout.Parsing.Whitespace 108 | Scout.PrettyPrinting 109 | Scout.Program 110 | Scout.Truncatable 111 | Scout.Unbound 112 | Text.Megaparsec.State.Optics 113 | other-modules: 114 | Prelude 115 | BasicEvaluation 116 | hs-source-dirs: 117 | prelude 118 | scout-src 119 | default-extensions: 120 | OverloadedStrings 121 | OverloadedLabels 122 | DisambiguateRecordFields 123 | DeriveGeneric 124 | ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat -Widentities -Wredundant-constraints -fhide-source-paths -fno-show-valid-hole-fits -j 125 | build-depends: 126 | Interpolation 127 | , QuickCheck 128 | , composition 129 | , containers 130 | , dictionary-sharing 131 | , frugel 132 | , generic-data >=0.8.0.0 && <0.9 133 | , genvalidity 134 | , genvalidity-containers 135 | , genvalidity-text 136 | , indexed-profunctors 137 | , it-has 138 | , lens 139 | , megaparsec >=9.0.1 && <9.1 140 | , mtl 141 | , multiset 142 | , optics ==0.4.* 143 | , optics-core ==0.4.* 144 | , parser-combinators 145 | , prettyprinter >=1.7.0 && <1.8 146 | , profunctors 147 | , relude >=1.0.0.0 148 | , size-based 149 | , testing-feat 150 | , validity-containers 151 | , validity-text 152 | if impl(ghcjs) 153 | build-depends: 154 | base-noprelude-ghcjs >=4.7 && <5 155 | else 156 | build-depends: 157 | base-noprelude >=4.7 && <5 158 | default-language: Haskell2010 159 | 160 | executable frugel-exe 161 | main-is: Main.hs 162 | other-modules: 163 | Prelude 164 | Control.Timeout 165 | Frugel.Web.Action 166 | Frugel.Web.Event 167 | Frugel.Web.Internal.Model 168 | Frugel.Web.Model 169 | Frugel.Web.View 170 | Frugel.Web.View.Elements 171 | Frugel.Web.View.Rendering 172 | Language.Javascript.JSaddle.Warp.Extra 173 | Paths_frugel 174 | hs-source-dirs: 175 | prelude 176 | app 177 | default-extensions: 178 | OverloadedStrings 179 | OverloadedLabels 180 | DisambiguateRecordFields 181 | DeriveGeneric 182 | ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat -Widentities -Wredundant-constraints -fhide-source-paths -fno-show-valid-hole-fits -j -threaded -rtsopts "-with-rtsopts=--nonmoving-gc -A16M -M1G -N -Mgrace=16M" -feager-blackholing 183 | ghcjs-options: -dedupe "-with-rtsopts=--nonmoving-gc -N" 184 | build-depends: 185 | Interpolation 186 | , QuickCheck 187 | , aeson 188 | , composition 189 | , frugel 190 | , lens 191 | , miso >=1.8.0.0 && <1.9 192 | , mtl 193 | , multiset 194 | , pretty-show 195 | , prettyprinter >=1.7.0 && <1.8 196 | , relude >=1.0.0.0 197 | , scout 198 | if impl(ghcjs) 199 | build-depends: 200 | base-noprelude-ghcjs >=4.7 && <5 201 | else 202 | build-depends: 203 | base-noprelude >=4.7 && <5 204 | , directory 205 | , filepath 206 | , jsaddle >=0.9.8 && <0.10 207 | , jsaddle-warp ==0.9.* 208 | , wai-app-static >=3.1.7 && <3.2 209 | , warp >=3.3.17 && <3.4 210 | , websockets >=0.12.7 && <0.13 211 | default-language: Haskell2010 212 | 213 | test-suite frugel-test 214 | type: exitcode-stdio-1.0 215 | main-is: Spec.hs 216 | other-modules: 217 | Prelude 218 | Data.NonNegative.GenValidity 219 | EvaluationSpec 220 | hs-source-dirs: 221 | prelude 222 | test 223 | default-extensions: 224 | OverloadedStrings 225 | OverloadedLabels 226 | DisambiguateRecordFields 227 | DeriveGeneric 228 | ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat -Widentities -Wredundant-constraints -fhide-source-paths -fno-show-valid-hole-fits -j -threaded -rtsopts -with-rtsopts=-N 229 | build-depends: 230 | QuickCheck 231 | , base-noprelude >=4.7 && <5 232 | , containers 233 | , frugel 234 | , genvalidity 235 | , genvalidity-containers 236 | , genvalidity-sydtest 237 | , mtl 238 | , multiset 239 | , relude >=1.0.0.0 240 | , scout 241 | , sydtest 242 | if impl(ghcjs) 243 | buildable: False 244 | default-language: Haskell2010 245 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | -------------------------------------------------------------------------------- /nix-stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: ghc-8.10.7 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | # packages: [] 32 | 33 | # Override default flag values for local packages and extra-deps 34 | # flags: {} 35 | 36 | # Extra package databases containing global packages 37 | # extra-package-dbs: [] 38 | 39 | # Control whether we use the GHC we find on the path 40 | system-ghc: true 41 | install-ghc: false 42 | 43 | # Require a specific version of stack, using version ranges 44 | # require-stack-version: -any # Default 45 | # require-stack-version: ">=2.5" 46 | # 47 | # Override the architecture used by stack, especially useful on Windows 48 | # arch: i386 49 | # arch: x86_64 50 | # 51 | # Extra directories used by stack for building 52 | # extra-include-dirs: [/path/to/dir] 53 | # extra-lib-dirs: [/path/to/dir] 54 | # 55 | # Allow a newer minor version of GHC than the snapshot specifies 56 | # compiler-check: newer-minor 57 | 58 | nix: 59 | enable: false 60 | -------------------------------------------------------------------------------- /nix/commit-hooks.nix: -------------------------------------------------------------------------------- 1 | { pkgs, floskell }: 2 | with pkgs; 3 | { 4 | floskellHook = { 5 | enable = false; 6 | name = "Floskell"; 7 | description = "A flexible Haskell source code pretty printer."; 8 | entry = "${floskell}/bin/floskell"; 9 | files = "\\.l?hs$"; 10 | }; 11 | floskellConfigChangeHook = { 12 | enable = false; 13 | name = "Floskell config change"; 14 | description = "Reformatting all Haskell files because the Floskell config has changed"; 15 | entry = "${bash}/bin/bash -c 'shopt -s globstar; ${floskell}/bin/floskell $(${coreutils}/bin/ls {prelude,app,src,test,scout-src}/**/*.hs | ${gnused}/bin/sed \"/app\\/\\(Control\\/Timeout\\|Language\\/Javascript\\/JSaddle\\/Warp\\/Extra\\).hs/d\")'"; 16 | files = "floskell.json$"; 17 | pass_filenames = false; 18 | }; 19 | buildHook = { 20 | enable = false; 21 | name = "build"; 22 | description = "A build of the project."; 23 | entry = "nix-build"; 24 | files = "package\\.yaml$"; 25 | pass_filenames = false; 26 | }; 27 | weederHook = { 28 | enable = false; 29 | name = "weeder"; 30 | description = "Check dead code"; 31 | entry = "${direnv}/bin/direnv exec . bash -c 'regen-hie ; weeder --require-hs-files'"; 32 | files = "\\.l?hs$"; 33 | pass_filenames = false; 34 | }; 35 | } 36 | -------------------------------------------------------------------------------- /nix/scripts.nix: -------------------------------------------------------------------------------- 1 | { pkgs, floskell }: 2 | let 3 | stack = "${pkgs.stack}/bin/stack"; 4 | in 5 | { 6 | reload-script = pkgs.writeShellScriptBin "reload" '' 7 | ${pkgs.ghcid}/bin/ghcid -c '\ 8 | ${stack} repl\ 9 | --only-main\ 10 | --ghci-options "-fdefer-type-errors +RTS -N -RTS"\ 11 | '\ 12 | --reload=www\ 13 | --restart=package.yaml\ 14 | -r -W 15 | ''; 16 | build-lib-script = pkgs.writeShellScriptBin "build-lib" "${stack} build --fast frugel:lib --ghc-options -fdefer-type-errors"; 17 | repl-script = pkgs.writeShellScriptBin "repl" "${stack} repl --ghci-options '+RTS -N -RTS -fdefer-type-errors'"; 18 | regen-hie-script = pkgs.writeShellScriptBin "regen-hie" "echo \"\" | ${stack} repl --ghc-options '-fwrite-ide-info -hiedir=.hie -ignore-dot-ghci' test/Spec.hs && mv .hie/Main.hie .hie/Spec.hie && echo \"\" | ${stack} repl --ghc-options '-fwrite-ide-info -hiedir=.hie -ignore-dot-ghci'"; 19 | format-all-script = pkgs.writeShellScriptBin "format-all" "shopt -s globstar; ${floskell}/bin/floskell {prelude,app,src,test,scout-src}/**/*.hs"; 20 | } 21 | -------------------------------------------------------------------------------- /nix/sources.json: -------------------------------------------------------------------------------- 1 | { 2 | "haskellNix": { 3 | "branch": "master", 4 | "description": "Alternative Haskell Infrastructure for Nixpkgs", 5 | "homepage": "https://input-output-hk.github.io/haskell.nix", 6 | "owner": "input-output-hk", 7 | "repo": "haskell.nix", 8 | "rev": "3aa5ffc0afef728894a08c33a06029997cfd3872", 9 | "sha256": "1d48s1s0lz0gcbrl5pml3nbfnx47dfv0m5kkrkcz56mcbjkkl847", 10 | "type": "tarball", 11 | "url": "https://github.com/input-output-hk/haskell.nix/archive/3aa5ffc0afef728894a08c33a06029997cfd3872.tar.gz", 12 | "url_template": "https://github.com///archive/.tar.gz" 13 | }, 14 | "pre-commit-hooks.nix": { 15 | "branch": "master", 16 | "description": "Seamless integration of https://pre-commit.com git hooks with Nix.", 17 | "homepage": "", 18 | "owner": "cachix", 19 | "repo": "pre-commit-hooks.nix", 20 | "rev": "3ed0e618cebc1ff291c27b749cf7568959cac028", 21 | "sha256": "0zni3zpz544p7bs7a87wjhd6wb7jmicx0sf2s5nrqapnxa97zcs4", 22 | "type": "tarball", 23 | "url": "https://github.com/cachix/pre-commit-hooks.nix/archive/3ed0e618cebc1ff291c27b749cf7568959cac028.tar.gz", 24 | "url_template": "https://github.com///archive/.tar.gz" 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /nix/sources.nix: -------------------------------------------------------------------------------- 1 | # This file has been generated by Niv. 2 | 3 | let 4 | 5 | # 6 | # The fetchers. fetch_ fetches specs of type . 7 | # 8 | 9 | fetch_file = pkgs: name: spec: 10 | let 11 | name' = sanitizeName name + "-src"; 12 | in 13 | if spec.builtin or true then 14 | builtins_fetchurl { inherit (spec) url sha256; name = name'; } 15 | else 16 | pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; 17 | 18 | fetch_tarball = pkgs: name: spec: 19 | let 20 | name' = sanitizeName name + "-src"; 21 | in 22 | if spec.builtin or true then 23 | builtins_fetchTarball { name = name'; inherit (spec) url sha256; } 24 | else 25 | pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; 26 | 27 | fetch_git = name: spec: 28 | let 29 | ref = 30 | if spec ? ref then spec.ref else 31 | if spec ? branch then "refs/heads/${spec.branch}" else 32 | if spec ? tag then "refs/tags/${spec.tag}" else 33 | abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; 34 | in 35 | builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; }; 36 | 37 | fetch_local = spec: spec.path; 38 | 39 | fetch_builtin-tarball = name: throw 40 | ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. 41 | $ niv modify ${name} -a type=tarball -a builtin=true''; 42 | 43 | fetch_builtin-url = name: throw 44 | ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. 45 | $ niv modify ${name} -a type=file -a builtin=true''; 46 | 47 | # 48 | # Various helpers 49 | # 50 | 51 | # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695 52 | sanitizeName = name: 53 | ( 54 | concatMapStrings (s: if builtins.isList s then "-" else s) 55 | ( 56 | builtins.split "[^[:alnum:]+._?=-]+" 57 | ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name) 58 | ) 59 | ); 60 | 61 | # The set of packages used when specs are fetched using non-builtins. 62 | mkPkgs = sources: system: 63 | let 64 | sourcesNixpkgs = 65 | import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; }; 66 | hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; 67 | hasThisAsNixpkgsPath = == ./.; 68 | in 69 | if builtins.hasAttr "nixpkgs" sources 70 | then sourcesNixpkgs 71 | else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then 72 | import {} 73 | else 74 | abort 75 | '' 76 | Please specify either (through -I or NIX_PATH=nixpkgs=...) or 77 | add a package called "nixpkgs" to your sources.json. 78 | ''; 79 | 80 | # The actual fetching function. 81 | fetch = pkgs: name: spec: 82 | 83 | if ! builtins.hasAttr "type" spec then 84 | abort "ERROR: niv spec ${name} does not have a 'type' attribute" 85 | else if spec.type == "file" then fetch_file pkgs name spec 86 | else if spec.type == "tarball" then fetch_tarball pkgs name spec 87 | else if spec.type == "git" then fetch_git name spec 88 | else if spec.type == "local" then fetch_local spec 89 | else if spec.type == "builtin-tarball" then fetch_builtin-tarball name 90 | else if spec.type == "builtin-url" then fetch_builtin-url name 91 | else 92 | abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; 93 | 94 | # If the environment variable NIV_OVERRIDE_${name} is set, then use 95 | # the path directly as opposed to the fetched source. 96 | replace = name: drv: 97 | let 98 | saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; 99 | ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; 100 | in 101 | if ersatz == "" then drv else 102 | # this turns the string into an actual Nix path (for both absolute and 103 | # relative paths) 104 | if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; 105 | 106 | # Ports of functions for older nix versions 107 | 108 | # a Nix version of mapAttrs if the built-in doesn't exist 109 | mapAttrs = builtins.mapAttrs or ( 110 | f: set: with builtins; 111 | listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) 112 | ); 113 | 114 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 115 | range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); 116 | 117 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 118 | stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); 119 | 120 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 121 | stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); 122 | concatMapStrings = f: list: concatStrings (map f list); 123 | concatStrings = builtins.concatStringsSep ""; 124 | 125 | # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 126 | optionalAttrs = cond: as: if cond then as else {}; 127 | 128 | # fetchTarball version that is compatible between all the versions of Nix 129 | builtins_fetchTarball = { url, name ? null, sha256 }@attrs: 130 | let 131 | inherit (builtins) lessThan nixVersion fetchTarball; 132 | in 133 | if lessThan nixVersion "1.12" then 134 | fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) 135 | else 136 | fetchTarball attrs; 137 | 138 | # fetchurl version that is compatible between all the versions of Nix 139 | builtins_fetchurl = { url, name ? null, sha256 }@attrs: 140 | let 141 | inherit (builtins) lessThan nixVersion fetchurl; 142 | in 143 | if lessThan nixVersion "1.12" then 144 | fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) 145 | else 146 | fetchurl attrs; 147 | 148 | # Create the final "sources" from the config 149 | mkSources = config: 150 | mapAttrs ( 151 | name: spec: 152 | if builtins.hasAttr "outPath" spec 153 | then abort 154 | "The values in sources.json should not have an 'outPath' attribute" 155 | else 156 | spec // { outPath = replace name (fetch config.pkgs name spec); } 157 | ) config.sources; 158 | 159 | # The "config" used by the fetchers 160 | mkConfig = 161 | { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null 162 | , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) 163 | , system ? builtins.currentSystem 164 | , pkgs ? mkPkgs sources system 165 | }: rec { 166 | # The sources, i.e. the attribute set of spec name to spec 167 | inherit sources; 168 | 169 | # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers 170 | inherit pkgs; 171 | }; 172 | 173 | in 174 | mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } 175 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: frugel 2 | version: 0.0.2.0 3 | github: "cdfa/frugel" 4 | license: GPL-3 5 | author: "Colin de Roos" 6 | maintainer: "colinderoos[at]gmail[dot]com" 7 | copyright: "2021 Colin de Roos" 8 | 9 | extra-source-files: 10 | - README.md 11 | 12 | data-dir: www 13 | data-files: 14 | - bulma.min.css 15 | - style.css 16 | - index.html 17 | 18 | # Metadata used when publishing your package 19 | # synopsis: Short description of your package 20 | # category: Web 21 | 22 | # To avoid duplicated efforts in documentation and dealing with the 23 | # complications of embedding Haddock markup inside cabal files, it is 24 | # common to point users to the README.md file. 25 | description: An Error-tolerant Live Programming Environment 26 | 27 | dependencies: 28 | - relude >= 1.0.0.0 29 | - mtl 30 | 31 | ghc-options: 32 | - -Wall 33 | - -Wincomplete-uni-patterns 34 | - -Wincomplete-record-updates 35 | - -Wcompat 36 | - -Widentities 37 | - -Wredundant-constraints 38 | - -fhide-source-paths 39 | - -fno-show-valid-hole-fits # Until https://gitlab.haskell.org/ghc/ghc/-/issues/16875 is resolved 40 | - -j 41 | 42 | default-extensions: 43 | - OverloadedStrings 44 | - OverloadedLabels 45 | - DisambiguateRecordFields 46 | - DeriveGeneric 47 | 48 | library: 49 | source-dirs: 50 | - prelude # In separate directory to share with other components to resolve issues with implicit prelude in ghci (also see https://github.com/commercialhaskell/stack/issues/3862) 51 | - src 52 | other-modules: Prelude 53 | when: 54 | - condition: impl(ghcjs) 55 | then: 56 | dependencies: base-noprelude-ghcjs >= 4.7 && < 5 57 | else: 58 | dependencies: base-noprelude >= 4.7 && < 5 59 | # Note: you may need to stack build before changes are reflected in the editor, because we use a cabal cradle for this component, because stack repl does not support internal libraries https://github.com/commercialhaskell/stack/issues/4564 60 | dependencies: 61 | - prettyprinter ^>= 1.7.0 62 | - composition 63 | - optics ^>= 0.4 64 | - optics-vl ^>= 0.2.1 65 | - lens 66 | 67 | internal-libraries: 68 | scout: 69 | when: 70 | - condition: impl(ghcjs) 71 | then: 72 | dependencies: base-noprelude-ghcjs >= 4.7 && < 5 73 | else: 74 | dependencies: base-noprelude >= 4.7 && < 5 75 | - condition: false # Work around hpack issue https://github.com/sol/hpack/issues/303 76 | other-modules: Paths_frugel 77 | source-dirs: 78 | - prelude 79 | - scout-src 80 | other-modules: 81 | - Prelude 82 | - BasicEvaluation 83 | dependencies: 84 | - frugel 85 | - megaparsec ^>= 9.0.1 86 | - parser-combinators 87 | - containers 88 | - prettyprinter ^>= 1.7.0 89 | - composition 90 | - it-has 91 | - optics ^>= 0.4 92 | - lens 93 | - multiset 94 | - genvalidity 95 | - validity-text 96 | - validity-containers 97 | - genvalidity-text 98 | - genvalidity-containers 99 | - QuickCheck 100 | - testing-feat 101 | - size-based 102 | - dictionary-sharing 103 | - generic-data ^>= 0.8.0.0 104 | - Interpolation 105 | # Until https://github.com/well-typed/optics/pull/430/files# is merged 106 | - optics-core ^>= 0.4 107 | - profunctors 108 | - indexed-profunctors 109 | 110 | executables: 111 | frugel-exe: 112 | main: Main.hs 113 | source-dirs: 114 | - prelude 115 | - app 116 | ghc-options: 117 | - -threaded 118 | - -rtsopts 119 | - '"-with-rtsopts=--nonmoving-gc -A16M -M1G -N -Mgrace=16M"' 120 | - -feager-blackholing 121 | ghcjs-options: 122 | - -dedupe 123 | - '"-with-rtsopts=--nonmoving-gc -N"' # sadly, it seems no heap overflow exceptions are thrown when the heap is limitied with ghcjs 124 | dependencies: 125 | - frugel 126 | - scout 127 | - miso ^>= 1.8.0.0 128 | - pretty-show 129 | - prettyprinter ^>= 1.7.0 130 | - aeson 131 | - QuickCheck 132 | - multiset 133 | - composition 134 | - lens 135 | - Interpolation 136 | when: 137 | - condition: impl(ghcjs) 138 | then: 139 | dependencies: base-noprelude-ghcjs >= 4.7 && < 5 140 | else: 141 | dependencies: 142 | - base-noprelude >= 4.7 && < 5 143 | - jsaddle ^>= 0.9.8 144 | - jsaddle-warp ^>= 0.9 145 | - websockets ^>= 0.12.7 146 | - warp ^>= 3.3.17 147 | - wai-app-static ^>= 3.1.7 148 | - directory 149 | - filepath 150 | 151 | tests: 152 | frugel-test: 153 | main: Spec.hs 154 | source-dirs: 155 | - prelude 156 | - test 157 | ghc-options: 158 | - -threaded 159 | - -rtsopts 160 | - -with-rtsopts=-N 161 | dependencies: 162 | - base-noprelude >= 4.7 && < 5 163 | - containers 164 | - frugel 165 | - scout 166 | - QuickCheck 167 | - genvalidity 168 | - genvalidity-containers 169 | - sydtest 170 | - genvalidity-sydtest 171 | - multiset 172 | when: 173 | - condition: impl(ghcjs) 174 | buildable: false 175 | - condition: false # Work around hpack issue https://github.com/sol/hpack/issues/303 176 | other-modules: Paths_frugel 177 | -------------------------------------------------------------------------------- /prelude/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Prelude 6 | ( module Prelude 7 | , module Relude 8 | , module Control.Monad.Reader 9 | , (><) 10 | , toList 11 | , dup 12 | ) where 13 | 14 | import Control.Monad.Reader 15 | ( MonadReader(..), Reader, ReaderT(ReaderT), asks, mapReader, mapReaderT 16 | , runReader, runReaderT, withReader, withReaderT ) 17 | 18 | import qualified Data.Foldable as Foldable 19 | import Data.List ( groupBy ) 20 | import Data.Sequence ( (><) ) 21 | 22 | import GHC.Exts 23 | 24 | import Relude 25 | hiding ( Sum, abs, group, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar 26 | , takeMVar, toList, truncate, tryPutMVar, tryReadMVar, tryTakeMVar ) 27 | import Relude.Extra.Tuple 28 | 29 | infixl 4 <<$> 30 | 31 | (<<$>) :: (Functor f, Functor g) => a -> f (g b) -> f (g a) 32 | (<<$>) a ffb = (a <$) <$> ffb 33 | 34 | infixr 9 <.> 35 | 36 | (<.>) :: Functor f => (a -> b) -> (c -> f a) -> c -> f b 37 | f1 <.> f2 = fmap f1 . f2 38 | 39 | lift2 :: forall (s :: (Type -> Type) 40 | -> Type 41 | -> Type) t m a. 42 | (MonadTrans s, MonadTrans t, Monad (t m), Monad m) 43 | => m a 44 | -> s (t m) a 45 | lift2 = lift . lift 46 | 47 | -- From https://hackage.haskell.org/package/utility-ht-0.0.16/docs/src/Data.Function.HT.Private.html#nest 48 | {-# INLINE nTimes #-} 49 | nTimes :: Int -> (a -> a) -> a -> a 50 | nTimes 0 _ x = x 51 | nTimes n f x = f (nTimes (n - 1) f x) 52 | 53 | applyWhen :: Bool -> (a -> a) -> a -> a 54 | applyWhen condition f = chain @Maybe (f <$ guard condition) 55 | 56 | chain :: Foldable t => t (a -> a) -> a -> a 57 | chain = foldr (.) id 58 | 59 | -- >>> concatBy leftToMaybe Left [Left "h", Left "i", Right 1] 60 | -- [Left "hi",Right 1] 61 | concatBy :: Monoid b => (a -> Maybe b) -> (b -> a) -> [a] -> [a] 62 | concatBy _ _ [] = [] 63 | concatBy toMonoid toElement xs = case spanMaybe toMonoid xs of 64 | ([], y : ys) -> y : concatBy' ys 65 | (zs, ys) -> toElement (mconcat zs) : concatBy' ys 66 | where 67 | concatBy' = concatBy toMonoid toElement 68 | 69 | -- From https://hackage.haskell.org/package/Cabal-3.4.0.0/docs/src/Distribution.Utils.Generic.html#spanMaybe 70 | -- >>> spanMaybe leftToMaybe [Left "h", Left "i", Right 1] 71 | -- (["h","i"],[Right 1]) 72 | spanMaybe :: (t -> Maybe a) -> [t] -> ([a], [t]) 73 | spanMaybe _ xs@[] = ([], xs) 74 | spanMaybe p xs@(x : xs') = case p x of 75 | Just y -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs) 76 | Nothing -> ([], xs) 77 | 78 | spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) 79 | spanEnd p = swap . bimap reverse reverse . span p . reverse 80 | 81 | -- Modified from https://hackage.haskell.org/package/hledger-lib-1.20.4/docs/src/Hledger.Utils.html#splitAtElement 82 | -- >>> splitOn ' ' " switch the accumulator to the other mode " 83 | -- ["","switch","","","the","accumulator","to","the","other","mode","","",""] 84 | splitOn :: Eq a => a -> [a] -> [[a]] 85 | splitOn x l = prefix : rest' 86 | where 87 | (prefix, rest) = break (x ==) l 88 | rest' = case rest of 89 | [] -> [] 90 | e : es | e == x -> splitOn x es 91 | es -> splitOn x es 92 | 93 | -- From: https://hackage.haskell.org/package/universe-base-1.1.2/docs/src/Data.Universe.Helpers.html#interleave 94 | -- | Fair n-way interleaving: given a finite number of (possibly infinite) 95 | -- lists, produce a single list such that whenever @v@ has finite index in one 96 | -- of the input lists, @v@ also has finite index in the output list. No list's 97 | -- elements occur more frequently (on average) than another's. 98 | interleave :: [[a]] -> [a] 99 | interleave = concat . transpose 100 | 101 | {-# INLINE fromFoldable #-} 102 | 103 | -- | Convert from 'Data.Foldable.Foldable' to an 'IsList' type. 104 | fromFoldable :: (Foldable f, IsList a) => f (Item a) -> a 105 | fromFoldable = fromList . Foldable.toList 106 | 107 | -- foldAlt :: (Foldable t, Alternative f) => t a -> f a 108 | -- foldAlt = getAlt . foldMap (Alt . pure) 109 | -- Copied from https://hackage.haskell.org/package/extra-1.7.9/docs/src/Data.List.Extra.html#groupSort 110 | groupSortOn :: Ord b => (a -> b) -> [a] -> [[a]] 111 | groupSortOn f 112 | = map (map snd) 113 | . groupBy ((==) `on` fst) 114 | . sortBy (compare `on` fst) 115 | . map (f &&& id) 116 | 117 | -- Copied from https://hackage.haskell.org/package/ilist-0.4.0.1/docs/src/Data.List.Index.html#insertAt 118 | {- | 119 | 'insertAt' inserts an element at the given position: 120 | 121 | @ 122 | (insertAt i x xs) !! i == x 123 | @ 124 | 125 | If the index is negative or exceeds list length, the original list will be returned. (If the index is equal to the list length, the insertion can be carried out.) 126 | -} 127 | insertAt :: Int -> a -> [a] -> [a] 128 | insertAt i a ls | i < 0 = ls 129 | | otherwise = go i ls 130 | where 131 | go 0 xs = a : xs 132 | go n (x : xs) = x : go (n - 1) xs 133 | go _ [] = [] 134 | -------------------------------------------------------------------------------- /scout-src/BasicEvaluation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | 13 | {-# OPTIONS_GHC -Wno-deprecations #-} 14 | 15 | -- This module is not used anywhere, but it's a nice playground for testing evaluation-related things 16 | module BasicEvaluation where 17 | 18 | import Data.Hidden 19 | import Data.Map 20 | import Data.Type.Equality 21 | 22 | type Expr = GExpr 'Syntax 23 | 24 | data ExprRepresentation = Syntax | Lifted | PartiallyReified 25 | 26 | -- todo: make instance explicit using kind-generics so we can remove Hidden 27 | data GExpr a where 28 | Var :: Name -> GExpr a 29 | App :: (a /~ 'Lifted) => GExpr a -> GExpr a -> GExpr a 30 | Abs :: (a /~ 'Lifted) => Name -> GExpr a -> GExpr a 31 | Lit :: Integer -> GExpr a 32 | Plus :: GExpr a -> GExpr a -> GExpr a 33 | LiftedApp :: GExpr 'Lifted 34 | -> Hidden (Evaluation (GExpr 'Lifted)) 35 | -> GExpr 'Lifted 36 | LiftedAbs :: Name 37 | -> Hidden (Evaluation (GExpr 'Lifted) -> Evaluation (GExpr 'Lifted)) 38 | -> GExpr 'Lifted 39 | GLiftedExpr :: GExpr 'Lifted -> GExpr 'PartiallyReified 40 | 41 | infix 4 /~ 42 | 43 | class (a == b) ~ 'False => (/~) (a :: k) (b :: k) 44 | 45 | instance (a == b) ~ 'False => (/~) a b 46 | 47 | -- want to make this only work on Syntax, but need kind-generics for it 48 | deriving instance Eq (GExpr a) 49 | 50 | deriving instance Show (GExpr a) 51 | 52 | -- deriving instance Data (GExpr Syntax) 53 | type Evaluation = IO 54 | 55 | type Name = String 56 | 57 | type EvaluationEnv = Map Name (Evaluation (GExpr 'Lifted)) 58 | 59 | interpret :: EvaluationEnv -> Expr -> Evaluation (GExpr 'Lifted) 60 | interpret env (Var n) = fromMaybe (pure $ Var n) $ lookup n env 61 | interpret env (App f x) = let ex = interpret env x in interpret env f >>= \case 62 | LiftedAbs _ (Hidden liftedFunction) -> liftedFunction ex 63 | ef -> pure $ LiftedApp ef $ Hidden ex 64 | interpret env (Abs n e) 65 | = pure $ LiftedAbs n $ Hidden (\x -> interpret (insert n x env) e) 66 | interpret _ (Lit i) = pure $ Lit i 67 | interpret env (Plus x y) = do 68 | ex <- interpret env x 69 | ey <- interpret env y 70 | pure $ case (ex, ey) of 71 | (Lit a, Lit b) -> Lit (a + b) 72 | _ -> Plus ex ey 73 | 74 | reifyToDepth :: Int -> GExpr 'Lifted -> IO (GExpr 'PartiallyReified) 75 | reifyToDepth 0 = pure . GLiftedExpr 76 | reifyToDepth depth = \case 77 | Var n -> pure $ Var n 78 | LiftedApp f (Hidden eArg) -> do 79 | arg <- eArg 80 | App <$> reifyToDepth (pred depth) f <*> reifyToDepth depth arg 81 | LiftedAbs n (Hidden f) -> do 82 | body <- f $ pure $ Var $ "fresh" ++ n 83 | Abs n <$> reifyToDepth depth body 84 | Lit i -> pure $ Lit i 85 | Plus left right -> 86 | Plus <$> reifyToDepth depth left <*> reifyToDepth depth right 87 | 88 | resumeReificationToDepth 89 | :: Int -> GExpr 'PartiallyReified -> IO (GExpr 'PartiallyReified) 90 | resumeReificationToDepth 0 = pure 91 | resumeReificationToDepth depth = \case 92 | GLiftedExpr liftedExpr -> reifyToDepth depth liftedExpr 93 | _ -> error "not implement yet" 94 | 95 | -- reifiedExpr -> uniplate (resumeReificationToDepth (pred depth)) reifiedExpr 96 | k :: Expr 97 | k = Abs "x" $ Abs "_" $ Var "x" 98 | 99 | s :: Expr 100 | s 101 | = Abs "f" . Abs "g" . Abs "x" 102 | $ App (App (Var "f") (Var "x")) (App (Var "g") (Var "x")) 103 | 104 | -- Simple test 105 | test :: IO (GExpr 'PartiallyReified) 106 | test = reifyToDepth 100 =<< interpret mempty (App (App (App s k) k) (Lit 3)) 107 | 108 | -- LiftedFunction is lazy 109 | test2 :: IO (GExpr 'PartiallyReified) 110 | test2 111 | = reifyToDepth 100 112 | =<< interpret mempty 113 | (App (App k (Lit 42)) (error "should not be evaluated")) 114 | 115 | -- LiftedFunction gets as far as possible with partial application 116 | test3 :: IO (GExpr 'PartiallyReified) 117 | test3 = reifyToDepth 100 =<< interpret mempty (App k $ Lit 5) 118 | 119 | -- Call-by-need 120 | test4 :: IO (GExpr 'PartiallyReified) 121 | test4 122 | = reifyToDepth 100 123 | =<< interpret 124 | mempty 125 | (App (Abs "x" $ Plus (Var "x") (Var "x")) $ trace "test" $ Lit 1) 126 | 127 | shadowingTest :: IO (GExpr 'PartiallyReified) 128 | shadowingTest 129 | = reifyToDepth 100 130 | =<< interpret 131 | mempty 132 | (App (Abs "x" $ Abs "x" $ Var "x") (error "should not be evaluated")) 133 | -------------------------------------------------------------------------------- /scout-src/Control/Enumerable/Combinators.hs: -------------------------------------------------------------------------------- 1 | module Control.Enumerable.Combinators where 2 | 3 | import Control.Enumerable 4 | 5 | import qualified Relude.Unsafe as Unsafe 6 | 7 | vectorOf :: Applicative f => Int -> Shareable f a -> Shareable f [a] 8 | vectorOf = replicateM 9 | 10 | elements :: (Typeable f, Sized f) => [a] -> Shareable f a 11 | elements xs = (xs Unsafe.!!) . fromInteger <$> finSized (toInteger $ length xs) 12 | 13 | inflation :: Sized f => (Int -> Int) -> a -> f (a -> a) -> f a 14 | inflation price zero incr = inflation' 0 15 | where 16 | inflation' n 17 | = pure zero <|> incr <*> splurge (price n) (inflation' (n + 1)) 18 | 19 | splurge :: Sized f => Int -> f a -> f a 20 | splurge n = foldr (.) id $ replicate n pay 21 | -------------------------------------------------------------------------------- /scout-src/Control/Limited.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | -- Provides a Monad and newtype for limiting recursion depth. Example: 8 | -- take :: Int -> [a] -> [a] 9 | -- take n xs = runIdentity $ runLimiterT (fromMaybe [] <$> draw (take' xs)) n 10 | -- where 11 | -- take' [] = pure $ Limited [] 12 | -- take' (y : ys) = Limited . (y :) . fromMaybe [] <$> draw (take' ys) 13 | module Control.Limited 14 | ( Limit(..) 15 | , Limiter 16 | , LimiterT 17 | , Limited(..) 18 | , MonadLimiter(..) 19 | , predLimit 20 | , runLimiter 21 | , runLimiterT 22 | , usingLimiter 23 | , usingLimiterT 24 | , mapLimiterT 25 | ) where 26 | 27 | import Control.Monad.Fix 28 | import Control.Monad.Writer.Class 29 | 30 | import Optics 31 | 32 | import Prelude hiding ( pass ) 33 | 34 | data Limit = Infinity | Only Int 35 | deriving ( Show, Eq ) 36 | 37 | newtype LimiterT m a = LimiterT { unLimiterT :: ReaderT Limit m a } 38 | deriving ( Functor, Applicative, Monad, MonadTrans, MonadFix, MonadWriter r 39 | , MonadIO ) 40 | 41 | type Limiter = LimiterT Identity 42 | 43 | newtype Limited a = Limited { unLimited :: a } 44 | 45 | instance Ord Limit where 46 | _ <= Infinity = True 47 | Infinity <= _ = False 48 | Only x <= Only y = x <= y 49 | 50 | class Monad m => MonadLimiter m where 51 | askLimit :: m Limit 52 | draw :: m (Limited a) -> m (Maybe a) 53 | 54 | instance Monad m => MonadLimiter (LimiterT m) where 55 | askLimit = LimiterT ask 56 | draw limited = do 57 | budget <- askLimit 58 | if budget <= Only 0 59 | then pure Nothing 60 | else (Just . unLimited) <.> LimiterT . local predLimit 61 | $ unLimiterT limited 62 | 63 | instance MonadLimiter m => MonadLimiter (ReaderT r m) where 64 | askLimit = lift askLimit 65 | draw = mapReaderT draw 66 | 67 | instance MonadReader r m => MonadReader r (LimiterT m) where 68 | ask = LimiterT . ReaderT $ const ask 69 | local = mapLimiterT . local 70 | 71 | instance Magnify m n b a => Magnify (LimiterT m) (LimiterT n) b a where 72 | magnify = mapLimiterT . magnify 73 | magnifyMaybe = mapLimiterT . magnifyMaybe 74 | 75 | predLimit :: Limit -> Limit 76 | predLimit Infinity = Infinity 77 | predLimit (Only x) = Only $ pred x 78 | 79 | runLimiter :: LimiterT Identity a -> Limit -> a 80 | runLimiter = runReader . unLimiterT 81 | 82 | usingLimiter :: Limit -> LimiterT Identity a -> a 83 | usingLimiter = flip runLimiter 84 | 85 | runLimiterT :: LimiterT m a -> Limit -> m a 86 | runLimiterT = runReaderT . unLimiterT 87 | 88 | usingLimiterT :: Limit -> LimiterT m a -> m a 89 | usingLimiterT = flip runLimiterT 90 | 91 | mapLimiterT :: (m a -> n b) -> LimiterT m a -> LimiterT n b 92 | mapLimiterT f = LimiterT . mapReaderT f . unLimiterT 93 | -------------------------------------------------------------------------------- /scout-src/Control/ValidEnumerable.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Control.ValidEnumerable 4 | ( module Control.ValidEnumerable.Class 5 | , module Control.ValidEnumerable.Access 6 | , module Control.Enumerable.Combinators 7 | ) where 8 | 9 | import Control.Enumerable.Combinators 10 | import Control.Sized 11 | import Control.ValidEnumerable.Access 12 | import Control.ValidEnumerable.Class 13 | 14 | import Data.Alphanumeric 15 | 16 | -- Size of characters grows for unicode characters 17 | -- because it would otherwise explode the number of possible values of any constructor taking it as an argument 18 | -- and thus reduce the likelihood of generating other constructors to near 0. 19 | instance ValidEnumerable Char where 20 | enumerateValid 21 | = share 22 | $ unAlphanumeric <$> accessValid 23 | <|> splurge 8 24 | (aconcat [ c0 ' ' 25 | , c0 '\n' 26 | , inflation id (minBound :: Char) (pure succ) 27 | ]) 28 | -------------------------------------------------------------------------------- /scout-src/Control/ValidEnumerable/Access.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module Control.ValidEnumerable.Access 4 | ( uniformValid 5 | , uniformWith 6 | , values 7 | , valuesWith 8 | ) where 9 | 10 | import Control.ValidEnumerable.Class 11 | 12 | import Data.ClassSharing 13 | 14 | import Prelude hiding ( local ) 15 | 16 | import Test.Feat hiding ( values ) 17 | import qualified Test.Feat.Access as Feat 18 | import Test.QuickCheck.Gen 19 | 20 | uniformValid :: ValidEnumerable a => Int -> Gen a 21 | uniformValid = uniformWith accessValid 22 | 23 | uniformWith :: Shareable Enumerate a -> Int -> Gen a 24 | uniformWith = Feat.uniformWith . global 25 | 26 | values :: ValidEnumerable a => [(Integer, [a])] 27 | values = valuesWith accessValid 28 | 29 | -- | Non class version of 'values'. 30 | valuesWith :: Shareable Enumerate a -> [(Integer, [a])] 31 | valuesWith = Feat.valuesWith . global 32 | 33 | {-# NOINLINE gref #-} 34 | gref :: Ref 35 | gref = unsafeNewRef () 36 | 37 | global :: Shareable f a -> f a 38 | global access = run access gref 39 | -- | Guarantees local sharing. All enumerations are shared inside each invocation of local, but may not be shared between them. 40 | -- {-# INLINE local #-} 41 | -- local :: Shareable f a -> f a 42 | -- local access = run access (unsafeNewRef ()) 43 | -------------------------------------------------------------------------------- /scout-src/Control/ValidEnumerable/Class.hs: -------------------------------------------------------------------------------- 1 | module Control.ValidEnumerable.Class 2 | ( module Control.ValidEnumerable.Class 3 | , datatype 4 | , share 5 | , Shared 6 | , Shareable 7 | , Typeable 8 | ) where 9 | 10 | import Control.Enumerable ( Infinite, datatype ) 11 | import Control.Sized 12 | 13 | import Data.ClassSharing 14 | 15 | import Test.QuickCheck.Modifiers 16 | 17 | class Typeable a => ValidEnumerable a where 18 | enumerateValid :: (Typeable f, Sized f) => Shared f a 19 | 20 | accessValid :: (ValidEnumerable a, Sized f, Typeable f) => Shareable f a 21 | accessValid = unsafeAccess enumerateValid 22 | 23 | c0 :: Sized f => a -> Shareable f a 24 | c0 = pure 25 | 26 | c1 :: (ValidEnumerable a, Sized f, Typeable f) => (a -> x) -> Shareable f x 27 | c1 f = fmap f accessValid 28 | 29 | c2 :: (ValidEnumerable a, ValidEnumerable b, Sized f, Typeable f) 30 | => (a -> b -> x) 31 | -> Shareable f x 32 | c2 f = c1 (uncurry f) 33 | 34 | c3 :: ( ValidEnumerable a 35 | , ValidEnumerable b 36 | , ValidEnumerable c 37 | , Sized f 38 | , Typeable f 39 | ) 40 | => (a -> b -> c -> x) 41 | -> Shareable f x 42 | c3 f = c2 (uncurry f) 43 | 44 | c4 :: ( ValidEnumerable a 45 | , ValidEnumerable b 46 | , ValidEnumerable c 47 | , ValidEnumerable d 48 | , Sized f 49 | , Typeable f 50 | ) 51 | => (a -> b -> c -> d -> x) 52 | -> Shareable f x 53 | c4 f = c3 (uncurry f) 54 | 55 | c5 :: ( ValidEnumerable a 56 | , ValidEnumerable b 57 | , ValidEnumerable c 58 | , ValidEnumerable d 59 | , ValidEnumerable e 60 | , Sized f 61 | , Typeable f 62 | ) 63 | => (a -> b -> c -> d -> e -> x) 64 | -> Shareable f x 65 | c5 f = c4 (uncurry f) 66 | 67 | c6 :: ( ValidEnumerable a 68 | , ValidEnumerable b 69 | , ValidEnumerable c 70 | , ValidEnumerable d 71 | , ValidEnumerable e 72 | , ValidEnumerable g 73 | , Sized f 74 | , Typeable f 75 | ) 76 | => (a -> b -> c -> d -> e -> g -> x) 77 | -> Shareable f x 78 | c6 f = c5 (uncurry f) 79 | 80 | c7 :: ( ValidEnumerable a 81 | , ValidEnumerable b 82 | , ValidEnumerable c 83 | , ValidEnumerable d 84 | , ValidEnumerable e 85 | , ValidEnumerable g 86 | , ValidEnumerable h 87 | , Sized f 88 | , Typeable f 89 | ) 90 | => (a -> b -> c -> d -> e -> g -> h -> x) 91 | -> Shareable f x 92 | c7 f = c6 (uncurry f) 93 | 94 | instance ValidEnumerable Bool where 95 | enumerateValid = datatype [ c0 False, c0 True ] 96 | 97 | instance Infinite integer => ValidEnumerable (NonNegative integer) where 98 | enumerateValid = share (NonNegative . fromInteger <$> naturals) 99 | 100 | instance (ValidEnumerable a, ValidEnumerable b) => ValidEnumerable (a, b) where 101 | enumerateValid = share $ pair accessValid accessValid 102 | 103 | instance ( ValidEnumerable a 104 | , ValidEnumerable b 105 | , ValidEnumerable c 106 | , ValidEnumerable d 107 | , ValidEnumerable e 108 | ) => ValidEnumerable (a, b, c, d, e) where 109 | enumerateValid = share $ c1 $ \(a, (b, (c, (d, e)))) -> (a, b, c, d, e) 110 | 111 | instance (ValidEnumerable a, ValidEnumerable b) 112 | => ValidEnumerable (Either a b) where 113 | enumerateValid = datatype [ c1 Left, c1 Right ] 114 | 115 | instance ValidEnumerable a => ValidEnumerable [a] where 116 | enumerateValid = datatype [ pure [], c2 (:) ] 117 | 118 | instance ValidEnumerable a => ValidEnumerable (Maybe a) where 119 | enumerateValid = datatype [ pure Nothing, c1 Just ] 120 | 121 | instance ValidEnumerable a => ValidEnumerable (Seq a) where 122 | enumerateValid = share (fromList <$> accessValid) 123 | 124 | instance ValidEnumerable a => ValidEnumerable (NonEmpty a) where 125 | enumerateValid = datatype [ c2 (:|) ] 126 | -------------------------------------------------------------------------------- /scout-src/Data/Alphanumeric.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module Data.Alphanumeric where 11 | 12 | import Control.Enumerable.Combinators as Enumerable 13 | import Control.Sized 14 | import Control.ValidEnumerable.Access 15 | import Control.ValidEnumerable.Class 16 | 17 | import Data.Char 18 | import Data.Data 19 | import Data.GenValidity 20 | 21 | import Optics 22 | 23 | import Prettyprinter 24 | 25 | import Test.QuickCheck.Gen hiding ( growingElements ) 26 | 27 | newtype Alphanumeric = Alphanumeric { unAlphanumeric :: Char } 28 | deriving ( Eq, Ord, Show, Generic, Data, Pretty ) 29 | 30 | makeFieldLabelsNoPrefix ''Alphanumeric 31 | 32 | instance Validity Alphanumeric where 33 | validate 34 | = mconcat [ genericValidate 35 | , declare "is an alpha-numeric character" 36 | . isAlphaNum 37 | . unAlphanumeric 38 | ] 39 | 40 | instance GenValid Alphanumeric where 41 | genValid = sized uniformValid 42 | shrinkValid = shrinkValidStructurallyWithoutExtraFiltering -- No filtering required, because shrinking maintains the alphanumeric invariant 43 | 44 | instance ValidEnumerable Alphanumeric where 45 | enumerateValid 46 | = share . pay . fmap Alphanumeric . Enumerable.elements 47 | $ [ '0' .. '9' ] ++ [ 'a' .. 'z' ] ++ [ 'A' .. 'Z' ] 48 | 49 | accessLetter :: (Sized f, Typeable f) => Shareable f Alphanumeric 50 | accessLetter 51 | = pay . fmap Alphanumeric . Enumerable.elements 52 | $ [ 'a' .. 'z' ] ++ [ 'A' .. 'Z' ] 53 | 54 | fromChar :: Char -> Maybe Alphanumeric 55 | fromChar = Alphanumeric <.> guarded isAlphaNum 56 | -------------------------------------------------------------------------------- /scout-src/Data/Constrained.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE UndecidableSuperClasses #-} 7 | 8 | module Data.Constrained where 9 | 10 | import Optics.Extra.Scout 11 | 12 | data Constrained c = forall a. c a => Constrained a 13 | 14 | fromConstrained :: (forall a. c a => a -> b) -> Constrained c -> b 15 | fromConstrained f (Constrained a) = f a 16 | 17 | _ConstrainedVL :: Functor f 18 | => (forall a. c a => a -> f a) 19 | -> Constrained c 20 | -> f (Constrained c) 21 | _ConstrainedVL f (Constrained a) = Constrained <$> f a 22 | 23 | _UnConstrained :: (Intro k is, ViewableOptic k r) 24 | => (forall s. c s => Optic' k is s r) 25 | -> Optic' k is (Constrained c) r 26 | _UnConstrained l = intro $ \(Constrained a) -> gview l a 27 | -------------------------------------------------------------------------------- /scout-src/Data/Hidden.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Data.Hidden where 4 | 5 | import Data.Data 6 | import Data.GenValidity 7 | 8 | import Optics 9 | 10 | import Text.Show 11 | 12 | -- | A type that is not interacted with in any other way than through the constructor. 13 | -- | This may be useful for derived data would otherwise prevent the definition of some instances for a data structure containing the data. 14 | -- | The defined instances may be ill-defined or break laws. 15 | -- | It is the programmers responsibility to ensure that functions constrained on these instances are not applied to values containing hidden data. 16 | newtype Hidden a = Hidden a 17 | deriving ( Typeable ) 18 | 19 | makePrisms ''Hidden 20 | 21 | instance Eq (Hidden a) where 22 | _ == _ = True -- What is hidden should not matter 23 | 24 | instance Show (Hidden a) where 25 | show _ = error "Attempt to show a Hidden value" 26 | 27 | instance Ord (Hidden a) where 28 | _ <= _ = True 29 | 30 | instance Typeable a => Data (Hidden a) where 31 | gfoldl _ z c = z c 32 | gunfold _ _ _ = error "gunfold used on Hidden" 33 | toConstr x = mkConstr (dataTypeOf x) "Hidden" [] Prefix 34 | dataTypeOf _ = mkNoRepType "Hidden" 35 | 36 | instance Validity (Hidden a) where 37 | validate _ = valid 38 | -------------------------------------------------------------------------------- /scout-src/Data/Sized.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | 4 | module Data.Sized where 5 | 6 | import Data.GenValidity 7 | 8 | data Sized (s :: Nat) a = Sized { size :: Proxy s, unSized :: a } 9 | deriving ( Show ) 10 | 11 | instance Validity a => Validity (Sized s a) where 12 | validate = validate . unSized 13 | -------------------------------------------------------------------------------- /scout-src/Data/Validity/Extra.hs: -------------------------------------------------------------------------------- 1 | module Data.Validity.Extra where 2 | 3 | import Data.Char 4 | import Data.GenValidity 5 | 6 | validateWhitespace :: ToString a => a -> Validation 7 | validateWhitespace 8 | = declare "The whitespace fragment contains only whitespace" 9 | . all isSpace 10 | . toString 11 | -------------------------------------------------------------------------------- /scout-src/Data/Whitespace.hs: -------------------------------------------------------------------------------- 1 | module Data.Whitespace where 2 | 3 | import Control.Enumerable.Combinators 4 | import Control.Sized 5 | import Control.ValidEnumerable.Class 6 | 7 | newtype Whitespace = Whitespace { unWhitespace :: Char } 8 | deriving ( Show ) 9 | 10 | instance ValidEnumerable Whitespace where 11 | enumerateValid = share . pay . fmap Whitespace $ elements " \t\n\r\f\v" 12 | 13 | enumerateWhitespace :: (Sized f, Typeable f) => Shareable f Text 14 | enumerateWhitespace 15 | = toText . map unWhitespace 16 | <$> inflation (pred . (2 *)) [] ((:) <$> accessValid) 17 | -------------------------------------------------------------------------------- /scout-src/Frugel/CstrSite/ValidEnumerable.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Frugel.CstrSite.ValidEnumerable where 4 | 5 | import Control.ValidEnumerable 6 | 7 | import Data.Composition 8 | import Data.GenValidity 9 | import Data.GenValidity.Sequence () 10 | 11 | import Frugel.CstrSite 12 | 13 | import Optics 14 | 15 | import Test.QuickCheck.Gen 16 | 17 | instance Validity n => Validity (ACstrSite n) 18 | 19 | instance (ValidEnumerable n, GenValid n) => GenValid (ACstrSite n) where 20 | genValid = sized uniformValid 21 | shrinkValid = shrinkValidStructurallyWithoutExtraFiltering 22 | 23 | instance ValidEnumerable n => ValidEnumerable (ACstrSite n) where 24 | enumerateValid 25 | = datatype 26 | [ splurge 6 $ pure $ fromList [] 27 | , splurge 3 $ fromList .: (<|) <$> accessValid <*> accessValid 28 | ] 29 | -------------------------------------------------------------------------------- /scout-src/Optics/Extra/Scout.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Optics.Extra.Scout 6 | ( module Optics.Extra.Scout 7 | , module Optics.Extra.Frugel 8 | , module Optics.ReadOnly.Intro 9 | , module Optics.ReadOnly.VL 10 | , module Optics.ReadOnly.FunctorOptic 11 | , module Optics.Fallible 12 | ) where 13 | 14 | import Data.Has 15 | 16 | import Optics.Extra.Frugel hiding ( foldVL ) 17 | import Optics.Fallible 18 | import Optics.ReadOnly.FunctorOptic 19 | import Optics.ReadOnly.Intro 20 | import Optics.ReadOnly.VL 21 | 22 | -- Can't use tuple directly, because GHC can't do impredicative types yet 23 | -- data instead of newtype because of existential quantification 24 | data Traverser' f k is s = forall a. Traverser' (Optic' k is s a) (a -> f a) 25 | 26 | newtype Disjoint a = Disjoint { unDisjoint :: [a] } 27 | 28 | chainDisJoint :: (Applicative f, Is k A_Setter, Is k An_AffineFold) 29 | => n 30 | -> Disjoint (Traverser' f k is n) 31 | -> f n 32 | chainDisJoint s = foldr foldOp (pure s) . unDisjoint 33 | where 34 | foldOp (Traverser' optic f) s' = maybe s' setComponent $ preview optic s 35 | where 36 | setComponent component = set optic <$> f component <*> s' 37 | 38 | concatByPrism :: (Is k An_AffineFold, Is k A_Review, Monoid a) 39 | => Optic' k is s a 40 | -> [s] 41 | -> [s] 42 | concatByPrism p = concatBy (preview p) (review p) 43 | 44 | hasLens :: Has a s => Lens' s a 45 | hasLens = lens getter (\t b -> modifier (const b) t) 46 | 47 | fromAffineFold :: Is k An_AffineFold => a -> Optic' k is s a -> s -> a 48 | fromAffineFold a afold = fromMaybe a . preview afold 49 | 50 | cosmosOf :: forall k a. Is k A_Fold => Optic' k NoIx a a -> Fold a a 51 | cosmosOf l = simple `summing` castOptic @A_Fold l % cosmosOf l 52 | 53 | like :: a -> Getter b a 54 | like a = to (const a) 55 | -------------------------------------------------------------------------------- /scout-src/Optics/Fallible.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module Optics.Fallible where 11 | 12 | import Data.Type.Equality 13 | 14 | import Optics 15 | import Optics.Internal.Utils 16 | 17 | class FallibleOptic k l m s t a b | k l -> m where 18 | {-| 19 | NB: @gfailing k l@ only produces legal R/W optics when the foci of @k@ and @l@ are disjoint or @l@ focuses at least as "deep" as @k@. 20 | For example, @_tail \`gfailing\` simple@ is illegal, because composition is not preserved, i.e. with @o = _tail \`gfailing\` simple@, @Identity . cons 1@ and @g = Identity . cons 2@, we have 21 | 22 | @ 23 | getCompose $ traverseOf o (Compose . fmap f . g) [] ≡ Identity (Identity [ 1 , 2 ]) 24 | /= Identity (Identity [ 2 , 1 ]) ≡ fmap (traverseOf o f) $ traverseOf o g [] 25 | @ 26 | 27 | On the other hand, @ix i \`gfailing\` _last@ would be legal. 28 | In other words, the success/failure of @k@ cannot depend on the values of @l@'s foci. 29 | -} 30 | gfailing 31 | :: Optic k is s t a b -> Optic l is s t a b -> Optic m NoIx s t a b 32 | 33 | infixl 3 `gfailing` -- Same as (<|>) 34 | 35 | -- Prism 36 | instance FallibleOptic A_Prism An_Iso A_Lens s t a b where 37 | gfailing k l = gfailing k $ castOptic @A_Lens l 38 | 39 | instance FallibleOptic A_Prism A_Lens A_Lens s t a b where 40 | gfailing k l = gfailing (castOptic @An_AffineTraversal k) l 41 | 42 | instance FallibleOptic A_Prism A_Prism An_AffineTraversal s t a b where 43 | gfailing = gfailing `on` castOptic @An_AffineTraversal 44 | 45 | instance FallibleOptic A_Prism A_Getter A_Getter s s a a where 46 | gfailing k l = gfailing (castOptic @An_AffineFold k) l 47 | 48 | -- AffineTraversal 49 | instance FallibleOptic An_AffineTraversal A_Lens A_Lens s t a b where 50 | gfailing k l = withAffineTraversal k $ \matchK _ -> withLens l $ \viewL _ -> 51 | lens (\s -> fromRight (viewL s) $ matchK s) 52 | (\s b -> fromMaybe (set l b s) $ failover k (const b) s) 53 | 54 | instance FallibleOptic An_AffineTraversal An_AffineTraversal An_AffineTraversal s t a b where 55 | gfailing k l = atraversalVL $ \point f s -> let 56 | OrT visited fu = atraverseOf k (OrT False . point) (wrapOrT . f) s 57 | in if visited then fu else atraverseOf l point f s 58 | 59 | -- AffineFold 60 | instance FallibleOptic An_AffineFold A_Getter A_Getter s s a a where 61 | gfailing k l = to $ \s -> fromMaybe (view l s) $ preview k s 62 | 63 | instance FallibleOptic An_AffineFold An_AffineFold An_AffineFold s s a a where 64 | gfailing k l = afolding $ \s -> preview l s <|> preview k s 65 | 66 | -- Traversal 67 | instance FallibleOptic A_Traversal A_Traversal A_Traversal s t a b where 68 | gfailing k l = traversalVL $ \f s -> let 69 | OrT visited fu = traverseOf k (wrapOrT . f) s 70 | in if visited then fu else traverseOf l f s 71 | 72 | -- Fold 73 | instance FallibleOptic A_Fold A_Fold A_Fold s s a a where 74 | gfailing k l = foldVL $ \f s -> let 75 | OrT visited fu = traverseOf_ k (wrapOrT . f) s 76 | in if visited then fu else traverseOf_ l f s 77 | 78 | instance {-# OVERLAPPABLE #-}( JoinKinds k l m 79 | , Is k m 80 | , Is l m 81 | , FallibleOptic m m m s t a b 82 | , (k == l) ~ 'False 83 | ) => FallibleOptic k l m s t a b where 84 | gfailing k l = gfailing (castOptic @m k) (castOptic @m l) 85 | -------------------------------------------------------------------------------- /scout-src/Optics/ReadOnly/FunctorOptic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | module Optics.ReadOnly.FunctorOptic where 9 | 10 | import Data.Composition 11 | import Data.Sequence.Optics 12 | 13 | import Optics 14 | import Optics.ReadOnly.Intro 15 | 16 | class Applicative (ViewFunctor k) => FunctorOptic k where 17 | type ViewFunctor k :: Type -> Type 18 | gview' :: MonadReader s m => Optic' k is s r -> m (ViewFunctor k r) 19 | default gview' :: ( ViewResult k r ~ ViewFunctor k r 20 | , ViewableOptic k r 21 | , MonadReader s m 22 | ) 23 | => Optic' k is s r 24 | -> m (ViewFunctor k r) 25 | gview' = gview 26 | intro' :: (a -> ViewFunctor k r) -> Optic' k NoIx a r 27 | 28 | instance FunctorOptic A_Getter where 29 | type ViewFunctor A_Getter = Identity 30 | gview' = flip gviews Identity 31 | intro' f = intro $ runIdentity . f 32 | 33 | instance FunctorOptic An_AffineFold where 34 | type ViewFunctor An_AffineFold = Maybe 35 | intro' f = to f % _Just 36 | 37 | instance FunctorOptic A_Fold where 38 | type ViewFunctor A_Fold = Seq 39 | gview' = asks . seqOf 40 | intro' f = to f % folded 41 | 42 | onOptic :: forall k is js ks s a p q o n. 43 | (JoinKinds k A_Getter k, FunctorOptic k, AppendIndices is js ks) 44 | => ((s -> ViewFunctor k a) 45 | -> (p -> ViewFunctor k q) 46 | -> o 47 | -> ViewFunctor k n) 48 | -> Optic' k is s a 49 | -> Optic' k js p q 50 | -> Optic' k NoIx o n 51 | onOptic combinator leftOptic rightOptic 52 | = const' (intro' $ combinator (gview' leftOptic) (gview' rightOptic)) 53 | (leftOptic % magic) 54 | where 55 | const' = const -- to avoid hlint hint 56 | magic 57 | = error "Use % to remove redundant constraint warning about useful JoinKinds" 58 | :: Optic' A_Getter js a () 59 | 60 | infixr 3 `fanout` 61 | 62 | fanout :: forall m ks k is s a l js q o ls. 63 | ( Is k o 64 | , Is l o 65 | , JoinKinds k l m 66 | , JoinKinds m A_Getter o 67 | , JoinKinds o A_Getter o 68 | , AppendIndices is js ks 69 | , AppendIndices ks ks ls 70 | , FunctorOptic o 71 | ) 72 | => Optic' k is s a 73 | -> Optic' l js s q 74 | -> Optic' o NoIx s (a, q) 75 | fanout leftOptic rightOptic 76 | = const' (onOptic (uncurry (liftA2 (,)) .:. (&&&)) 77 | (castOptic leftOptic) 78 | (castOptic rightOptic)) 79 | (leftOptic % magic rightOptic % magicReversePrism) 80 | where 81 | const' = const -- to avoid hlint hint 82 | magic 83 | = error "Use % to remove redundant constraint warning about useful JoinKinds k l m" 84 | :: Optic' l js s q -> Optic' l js a q 85 | magicReversePrism 86 | = error "Use % to remove redundant constraint warning about useful JoinKinds m A_Getter o" 87 | :: Optic' A_Getter ks q f 88 | -------------------------------------------------------------------------------- /scout-src/Optics/ReadOnly/Intro.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | 5 | module Optics.ReadOnly.Intro where 6 | 7 | import Optics 8 | 9 | class Intro k is where 10 | intro :: ViewableOptic k r => (a -> ViewResult k r) -> Optic' k is a r 11 | 12 | instance Intro A_Getter NoIx where 13 | intro = to 14 | 15 | instance Intro An_AffineFold NoIx where 16 | intro = afolding 17 | 18 | instance Intro A_Fold NoIx where 19 | intro = castOptic @A_Fold . to 20 | -------------------------------------------------------------------------------- /scout-src/Optics/ReadOnly/VL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TupleSections #-} 6 | 7 | {-# LANGUAGE TypeApplications #-} 8 | 9 | {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 10 | {-# OPTIONS_GHC -Wno-missing-methods #-} 11 | {-# OPTIONS_GHC -Wno-redundant-constraints #-} 12 | 13 | -- Copied from https://github.com/well-typed/optics/pull/430/files# 14 | module Optics.ReadOnly.VL 15 | ( GetterVL 16 | , getterVL 17 | , toGetterVL 18 | , FoldVL 19 | , foldVL 20 | , toFoldVL 21 | ) where 22 | 23 | import qualified Data.Profunctor as P 24 | import qualified Data.Profunctor.Indexed as IP 25 | 26 | import Optics.Core hiding ( foldVL ) 27 | import qualified Optics.Core as O 28 | import Optics.Internal.Bi 29 | import Optics.Internal.Optic 30 | import Optics.Internal.Utils 31 | 32 | newtype WrappedProfunctor p f i a b 33 | = WrapProfunctor { unwrapProfunctor :: p a (f b) } 34 | 35 | instance (P.Profunctor p, Functor f) 36 | => IP.Profunctor (WrappedProfunctor p f) where 37 | dimap f g (WrapProfunctor pafb) = WrapProfunctor (P.dimap f (fmap g) pafb) 38 | lmap f (WrapProfunctor pafb) = WrapProfunctor (P.lmap f pafb) 39 | rmap g (WrapProfunctor pafb) = WrapProfunctor (P.rmap (fmap g) pafb) 40 | {-# INLINE dimap #-} 41 | {-# INLINE lmap #-} 42 | {-# INLINE rmap #-} 43 | lcoerce' = IP.lmap coerce 44 | rcoerce' = IP.rmap coerce 45 | {-# INLINE lcoerce' #-} 46 | {-# INLINE rcoerce' #-} 47 | 48 | instance (P.Choice p, Applicative f) => IP.Choice (WrappedProfunctor p f) where 49 | left' (WrapProfunctor pafb) 50 | = WrapProfunctor (P.rmap (either (fmap Left) (pure . Right)) 51 | (P.left' pafb)) 52 | right' (WrapProfunctor pafb) 53 | = WrapProfunctor (P.rmap (either (pure . Left) (fmap Right)) 54 | (P.right' pafb)) 55 | {-# INLINE left' #-} 56 | {-# INLINE right' #-} 57 | 58 | instance (P.Strong p, Functor f) => IP.Strong (WrappedProfunctor p f) where 59 | first' (WrapProfunctor pafb) 60 | = let shuffle (fb, c) = (, c) <$> fb 61 | in WrapProfunctor (P.rmap shuffle (P.first' pafb)) 62 | second' (WrapProfunctor pafb) 63 | = let shuffle (c, fb) = (c, ) <$> fb 64 | in WrapProfunctor (P.rmap shuffle (P.second' pafb)) 65 | {-# INLINE first' #-} 66 | {-# INLINE second' #-} 67 | 68 | instance (P.Profunctor p, Contravariant f, Functor f) 69 | => Bicontravariant (WrappedProfunctor p f) where 70 | contrabimap f g (WrapProfunctor pafb) 71 | = WrapProfunctor (P.dimap f (contramap g) pafb) 72 | contrafirst f (WrapProfunctor pafb) = WrapProfunctor (P.lmap f pafb) 73 | contrasecond g (WrapProfunctor pafb) 74 | = WrapProfunctor (P.rmap (contramap g) pafb) 75 | {-# INLINE contrabimap #-} 76 | {-# INLINE contrafirst #-} 77 | {-# INLINE contrasecond #-} 78 | 79 | instance Functor f => IP.Cochoice (WrappedProfunctor (->) f) where 80 | unleft (WrapProfunctor f) 81 | = WrapProfunctor (fmap (\(Left a) -> a) . f . Left) 82 | unright (WrapProfunctor f) 83 | = WrapProfunctor (fmap (\(Right a) -> a) . f . Right) 84 | {-# INLINE unleft #-} 85 | {-# INLINE unright #-} 86 | 87 | instance Applicative f => IP.Visiting (WrappedProfunctor (->) f) where 88 | visit f (WrapProfunctor afb) = WrapProfunctor (f pure afb) 89 | {-# INLINE visit #-} 90 | 91 | instance Applicative f => IP.Traversing (WrappedProfunctor (->) f) where 92 | wander f (WrapProfunctor afb) = WrapProfunctor (f afb) 93 | {-# INLINE wander #-} 94 | 95 | type GetterVL s a 96 | = forall f. (Contravariant f, Functor f) => (a -> f a) -> s -> f s 97 | 98 | -- | Build a 'Getter' from the van Laarhoven representation. 99 | getterVL :: GetterVL s a -> Getter s a 100 | getterVL o = to (getConst #. o Const) 101 | 102 | {-# INLINE getterVL #-} 103 | 104 | -- | Convert a 'Getter' to the van Laarhoven representation. 105 | toGetterVL :: Is k A_Getter => Optic' k is s a -> GetterVL s a 106 | toGetterVL o 107 | = unwrapProfunctor #. getOptic (castOptic @A_Getter o) .# WrapProfunctor 108 | 109 | {-# INLINE toGetterVL #-} 110 | 111 | ---------------------------------------- 112 | type FoldVL s a 113 | = forall f. (Contravariant f, Applicative f) => (a -> f a) -> s -> f s 114 | 115 | -- | Build a 'Fold' from the van Laarhoven representation. 116 | foldVL :: FoldVL s a -> Fold s a 117 | foldVL o = O.foldVL $ \f -> runTraversed 118 | . getConst #. o (Const #. Traversed #. f) 119 | 120 | {-# INLINE foldVL #-} 121 | 122 | -- | Convert a 'Fold' to the van Laarhoven representation. 123 | toFoldVL :: Is k A_Fold => Optic' k is s a -> FoldVL s a 124 | toFoldVL o 125 | = unwrapProfunctor #. getOptic (castOptic @A_Fold o) .# WrapProfunctor 126 | 127 | {-# INLINE toFoldVL #-} 128 | -------------------------------------------------------------------------------- /scout-src/Optics/Writer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Optics.Writer where 4 | 5 | import Control.Monad.Writer.Class 6 | 7 | import Optics 8 | 9 | import Prelude hiding ( pass ) 10 | 11 | tellFragment :: (Is k A_Setter, MonadWriter t m, Monoid s) 12 | => Optic k is s t a b 13 | -> b 14 | -> m () 15 | tellFragment l b = tell $ set l b mempty 16 | 17 | {-# INLINE tellFragment #-} 18 | 19 | writerFragment :: (Is k A_Setter, MonadWriter t m, Monoid s) 20 | => Optic k is s t a b 21 | -> (q, b) 22 | -> m q 23 | writerFragment setter (q, output) = writer (q, mempty & setter .~ output) 24 | 25 | writerFragment' :: (Is k A_Setter, MonadWriter t m, Monoid s) 26 | => Optic k is s t a b 27 | -> q 28 | -> b 29 | -> m q 30 | writerFragment' setter = curry $ writerFragment setter 31 | 32 | listening 33 | :: (Is k A_Getter, MonadWriter w m) => Optic' k is w u -> m a -> m (a, u) 34 | listening l = listens $ view l 35 | 36 | {-# INLINE listening #-} 37 | 38 | censoring :: (Is k A_Setter, MonadWriter w m) 39 | => Optic k is w w u v 40 | -> (u -> v) 41 | -> m a 42 | -> m a 43 | censoring l uv = censor (over l uv) 44 | 45 | {-# INLINE censoring #-} -------------------------------------------------------------------------------- /scout-src/PrettyPrinting/Expr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module PrettyPrinting.Expr where 4 | 5 | import GHC.Generics ( Associativity(..) ) 6 | 7 | class Expression e where 8 | -- higher precedence binds weaker (because you shouldn't be able to bind stronger than a literal) 9 | precedence :: e -> Int 10 | fixity :: e -> Maybe Fixity 11 | associativity :: e -> Maybe Associativity 12 | 13 | -- fixity Abstraction{} = Just Prefix 14 | -- fixity _ = Nothing 15 | data Fixity = Prefix | Infix | Postfix 16 | deriving ( Eq, Show ) 17 | 18 | -- Finds the precedence of an operator `op` in a nested list of operators 19 | -- The result should be modified according to the precedence of the arity of operators when using with makeExprPrettyPrinter 20 | -- precedence :: Eq o => o -> [[o]] -> Int 21 | -- precedence op = fromJust . findIndex isJust . map (elemIndex op) 22 | {--} 23 | -- pretty prints an expression with minimal parentheses according to 24 | -- precedence function `precedence`, 25 | -- parenthesizing function `parenthesized` 26 | -- and pretty printing function `prettyPrint` 27 | makeExprPrettyPrinter :: (Expression e) 28 | => (e -> e) -- parenthesizing function 29 | -> ( e 30 | -> e 31 | -> e 32 | , e 33 | -> e 34 | -> e 35 | -> (e, e) -- pretty print binary expression 36 | ) 37 | makeExprPrettyPrinter parenthesized = (prettyPrintUnary, prettyPrintBinary) 38 | where 39 | prettyPrintUnary e subExp 40 | = parenthesize (succ $ precedence e) (fixity e == fixity subExp) subExp 41 | prettyPrintBinary e left right 42 | = (\(maxLeftPrecedence, maxRightPrecedence) -> 43 | ( parenthesize maxLeftPrecedence False left 44 | , parenthesize maxRightPrecedence False right 45 | )) $ maxPrecedenceByAssociativity e 46 | maxPrecedenceByAssociativity e 47 | = flip (maybe 48 | $ error "prettyPrintBinary used with non-binary expression (associativity e === Nothing)") 49 | (associativity e) 50 | $ \case 51 | LeftAssociative -> (succ opPrecedence, opPrecedence) 52 | RightAssociative -> (opPrecedence, succ opPrecedence) 53 | NotAssociative -> (opPrecedence, opPrecedence) 54 | where 55 | opPrecedence = precedence e 56 | parenthesize maxPrecedence fixityObviatesParens subExp 57 | = if precedence subExp >= maxPrecedence && not fixityObviatesParens 58 | then parenthesized subExp 59 | else subExp 60 | -------------------------------------------------------------------------------- /scout-src/Scout.hs: -------------------------------------------------------------------------------- 1 | module Scout 2 | ( module Scout.Node 3 | , module Scout.Program 4 | , module Scout.Evaluation 5 | , module Scout.Error 6 | , module Control.Limited 7 | , module Scout.PrettyPrinting 8 | , module Scout.Unbound 9 | , module Scout.Truncatable 10 | ) where 11 | 12 | import Control.Limited 13 | 14 | import Scout.Error 15 | import Scout.Evaluation 16 | import Scout.Node hiding ( EvaluationOutput(..) ) 17 | import Scout.PrettyPrinting 18 | import Scout.Program 19 | import Scout.Truncatable 20 | import Scout.Unbound 21 | -------------------------------------------------------------------------------- /scout-src/Scout/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Scout.Error where 4 | 5 | import qualified Frugel 6 | import Frugel.DisplayProjection 7 | 8 | import Optics 9 | 10 | import Scout.Node 11 | import Scout.Parsing.Error 12 | import Scout.Program 13 | 14 | data Error 15 | = EvaluationError Int EvaluationError 16 | | ParseError ParseError 17 | | InternalError (Frugel.InternalError Program) 18 | deriving ( Show, Eq ) 19 | 20 | instance DisplayProjection Error where 21 | renderDoc = \case 22 | EvaluationError count e -> "Evaluation error" 23 | <> plural mempty 24 | (" (occurring" <+> pretty count <+> "times)") 25 | count 26 | <> ":" 27 | <+> renderDoc e 28 | ParseError e -> parseErrorPretty e 29 | InternalError e -> "Internal error:" <+> renderDoc e 30 | 31 | fromFrugelError :: Frugel.Error Program -> Error 32 | fromFrugelError (Frugel.ParseError e) = ParseError e 33 | fromFrugelError (Frugel.InternalError e) = InternalError e 34 | 35 | matchFrugelError :: Error -> Either (Frugel.Error Program) Error 36 | matchFrugelError (ParseError e) = Left $ Frugel.ParseError e 37 | matchFrugelError (InternalError e) = Left $ Frugel.InternalError e 38 | matchFrugelError e@EvaluationError{} = Right e 39 | 40 | _FrugelError :: Prism' Error (Frugel.Error Program) 41 | _FrugelError = prism' fromFrugelError (leftToMaybe . matchFrugelError) 42 | -------------------------------------------------------------------------------- /scout-src/Scout/Internal/EvaluationEnv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DerivingVia #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NamedFieldPuns #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | module Scout.Internal.EvaluationEnv where 13 | 14 | import Control.Limited 15 | 16 | import qualified Data.Map as Map 17 | import qualified Data.Set as Set 18 | 19 | import Optics 20 | 21 | import Scout.Node 22 | 23 | data EvaluationEnv 24 | = EvaluationEnv { valueEnv :: Map Identifier (EvaluationRef Expr) 25 | -- used for tracking all bindings up to the first application (renameShadowedVariables takes over from there) 26 | , shadowingEnv :: ShadowingEnv 27 | , definitions :: Set Identifier 28 | , initialFuel :: Limit 29 | , skipNextOutOfFuel :: Bool 30 | } 31 | 32 | makeFieldLabelsNoPrefix ''EvaluationEnv 33 | 34 | makePrisms ''EvaluationEnv 35 | 36 | magnifyShadowingEnv :: Magnify m n EvaluationEnv ShadowingEnv 37 | => Identifier 38 | -> EvaluationRef Expr 39 | -> EvaluationEnv 40 | -> m c 41 | -> n c 42 | magnifyShadowingEnv n arg EvaluationEnv{shadowingEnv = _, ..} 43 | = magnify . to $ \shadowingEnv -> 44 | EvaluationEnv { valueEnv = Map.insert n arg valueEnv 45 | , shadowingEnv 46 | , definitions = Set.delete n definitions 47 | , initialFuel 48 | , skipNextOutOfFuel 49 | } 50 | -------------------------------------------------------------------------------- /scout-src/Scout/Lexing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module Scout.Lexing where 4 | 5 | import Data.Alphanumeric 6 | import Data.Char 7 | import qualified Data.Set as Set 8 | 9 | import Prelude hiding ( some ) 10 | 11 | import Scout.Node 12 | import Scout.Parsing.Error 13 | 14 | import Text.Megaparsec 15 | 16 | type Parser = Parsec ScoutParseError CstrSite 17 | 18 | namedToken :: MonadParsec e s m => String -> (Token s -> Maybe a) -> m a 19 | namedToken name test = token test Set.empty name 20 | 21 | char :: Char -> Parser Char 22 | char c = c <$ single (Left c) 23 | 24 | string :: String -> Parser String 25 | string s = s <$ chunk (fromList $ map Left s) 26 | 27 | alphaNumChar :: Parser Alphanumeric 28 | alphaNumChar 29 | = namedToken "an alphanumeric character" (leftToMaybe >=> fromChar) 30 | 31 | letter :: Parser Alphanumeric 32 | letter 33 | = namedToken "a letter in the alphabet" 34 | (leftToMaybe >=> guarded isLetter >=> fromChar) 35 | 36 | decimal :: (MonadParsec e s m, Token s ~ Either Char Node, Num a) => m a 37 | decimal = label "integer" $ foldl' step 0 <$> some digit 38 | where 39 | step a c = a * 10 + fromIntegral (digitToInt c) 40 | 41 | digit :: (MonadParsec e s m, Token s ~ Either Char Node) => m Char 42 | digit = namedToken "digit" (leftToMaybe >=> guarded isDigit) 43 | -------------------------------------------------------------------------------- /scout-src/Scout/Operators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | module Scout.Operators ( module Scout.Operators, Associativity(..) ) where 4 | 5 | import Control.ValidEnumerable 6 | 7 | import Data.Data hiding ( Fixity, Prefix ) 8 | import Data.GenValidity 9 | 10 | import GHC.Generics ( Associativity(..) ) 11 | 12 | import PrettyPrinting.Expr 13 | 14 | import Test.QuickCheck 15 | 16 | data UnaryOperator = Negate 17 | deriving ( Eq, Show, Ord, Data, Generic ) 18 | 19 | data BinaryOperator 20 | = Plus 21 | | Minus 22 | | Times 23 | | Division 24 | | Modulo 25 | | Equals 26 | | NotEquals 27 | | LessThan 28 | | GreaterThan 29 | | LessOrEqual 30 | | GreaterOrEqual 31 | | And 32 | | Or 33 | deriving ( Eq, Show, Ord, Data, Generic ) 34 | 35 | instance Validity UnaryOperator 36 | 37 | instance Validity BinaryOperator 38 | 39 | instance GenValid UnaryOperator where 40 | genValid = sized uniformValid 41 | shrinkValid = shrinkValid 42 | 43 | instance GenValid BinaryOperator where 44 | genValid = sized uniformValid 45 | shrinkValid = shrinkValid 46 | 47 | instance ValidEnumerable UnaryOperator where 48 | enumerateValid = datatype [ c0 Negate ] 49 | 50 | instance ValidEnumerable BinaryOperator where 51 | enumerateValid 52 | = datatype [ c0 Plus 53 | , c0 Minus 54 | , c0 Times 55 | , c0 Division 56 | , c0 Modulo 57 | , c0 Equals 58 | , c0 NotEquals 59 | , c0 LessThan 60 | , c0 GreaterThan 61 | , c0 LessOrEqual 62 | , c0 GreaterOrEqual 63 | , c0 And 64 | , c0 Or 65 | ] 66 | 67 | binaryOperatorPrecedence :: [[BinaryOperator]] 68 | binaryOperatorPrecedence 69 | = [ [ Times, Division ] 70 | , [ Plus, Minus, Modulo ] 71 | , [ LessThan, GreaterThan, LessOrEqual, GreaterOrEqual ] 72 | , [ Equals, NotEquals ] 73 | , [ And ] 74 | , [ Or ] 75 | ] 76 | 77 | unaryOperatorSymbol :: IsString p => UnaryOperator -> p 78 | unaryOperatorSymbol Negate = "-" 79 | 80 | binaryOperatorSymbol :: IsString p => BinaryOperator -> p 81 | binaryOperatorSymbol Plus = "+" 82 | binaryOperatorSymbol Minus = "-" 83 | binaryOperatorSymbol Times = "*" 84 | binaryOperatorSymbol Division = "/" 85 | binaryOperatorSymbol Modulo = "%" 86 | binaryOperatorSymbol Equals = "==" 87 | binaryOperatorSymbol NotEquals = "/=" 88 | binaryOperatorSymbol LessThan = "<" 89 | binaryOperatorSymbol GreaterThan = ">" 90 | binaryOperatorSymbol LessOrEqual = "<=" 91 | binaryOperatorSymbol GreaterOrEqual = ">=" 92 | binaryOperatorSymbol And = "&&" 93 | binaryOperatorSymbol Or = "||" 94 | 95 | fixity :: UnaryOperator -> Fixity 96 | fixity Negate = Prefix 97 | 98 | associativity :: BinaryOperator -> Associativity 99 | associativity Plus = LeftAssociative 100 | associativity Minus = LeftAssociative 101 | associativity Times = LeftAssociative 102 | associativity Division = LeftAssociative 103 | associativity Modulo = LeftAssociative 104 | associativity Equals = NotAssociative 105 | associativity NotEquals = NotAssociative 106 | associativity LessThan = NotAssociative 107 | associativity GreaterThan = NotAssociative 108 | associativity LessOrEqual = NotAssociative 109 | associativity GreaterOrEqual = NotAssociative 110 | associativity And = RightAssociative 111 | associativity Or = RightAssociative 112 | -------------------------------------------------------------------------------- /scout-src/Scout/Orphans/DisplayProjection.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | {-# OPTIONS_GHC -Wno-orphans #-} 4 | 5 | module Scout.Orphans.DisplayProjection where 6 | 7 | import Frugel 8 | 9 | import Scout.Node 10 | import Scout.PrettyPrinting 11 | import Scout.Truncatable 12 | 13 | -- Orphaned because of dependency on pretty printing 14 | instance DisplayProjection EvaluationError where 15 | renderDoc = \case 16 | TypeError e -> "Type error:" <+> renderDoc e 17 | FreeVariableError name -> dquotes (pretty name) <+> "was not defined" 18 | ConflictingDefinitionsError name -> dquotes (pretty name) 19 | <+> "was defined multiple times in a the same scope" 20 | OutOfFuelError expr -> "Ran out of fuel when evaluating:" 21 | `nestingLine` annotateComplete 22 | (reAnnotate toStandardAnnotation . annPretty $ truncate 5 expr) 23 | DivideByZeroError -> "Divide-by-zero error" 24 | 25 | instance DisplayProjection TypeError where 26 | renderDoc = \case 27 | TypeValueMismatch expected expr -> "Expected type" 28 | <+> pretty expected <> line <> "does not match" 29 | <+> annotateComplete 30 | (reAnnotate toStandardAnnotation . annPretty $ truncate 5 expr) 31 | LiteralTypesMismatch e1 e2 -> "Could not match types of" 32 | <+> renderDoc e1 33 | <+> "and" 34 | <+> renderDoc e2 35 | 36 | instance Pretty ExpectedType where 37 | pretty = \case 38 | FunctionType -> "Function" 39 | IntegerType -> "Integer" 40 | BoolType -> "Boolean" 41 | AnyType -> "Any" 42 | -------------------------------------------------------------------------------- /scout-src/Scout/Orphans/MultiSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | {-# OPTIONS_GHC -Wno-orphans #-} 4 | 5 | module Scout.Orphans.MultiSet where 6 | 7 | import Data.MultiSet 8 | 9 | instance One (MultiSet a) where 10 | type OneItem (MultiSet a) = a 11 | one = singleton 12 | -------------------------------------------------------------------------------- /scout-src/Scout/Orphans/Stream.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | {-# OPTIONS_GHC -Wno-orphans #-} 7 | 8 | module Scout.Orphans.Stream where 9 | 10 | import Frugel.CstrSite 11 | 12 | import Text.Megaparsec as Megaparsec 13 | 14 | deriving instance (Ord (Token s), Ord e) => Ord (Megaparsec.ParseError s e) 15 | 16 | deriving newtype instance Ord n => Stream (ACstrSite n) 17 | -------------------------------------------------------------------------------- /scout-src/Scout/Parsing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | module Scout.Parsing 7 | ( module Scout.Parsing 8 | , module Scout.Parsing.Error 9 | , module Scout.Parsing.Whitespace 10 | , module Scout.Lexing 11 | ) where 12 | 13 | import Control.Monad.Combinators.Expr 14 | 15 | import Data.Composition 16 | 17 | import Optics.Extra.Scout 18 | 19 | import Prelude hiding ( some ) 20 | 21 | import Scout.Lexing 22 | import Scout.Node 23 | import qualified Scout.Node as Node 24 | import Scout.Parsing.Error 25 | import Scout.Parsing.Whitespace 26 | 27 | import Text.Megaparsec as Megaparsec hiding ( ParseError, many, some ) 28 | import Text.Megaparsec.State.Optics () 29 | 30 | identifier :: Parser Identifier 31 | identifier 32 | = Identifier .: (:|) <$> letter <*> many alphaNumChar "an identifier" 33 | 34 | node :: (IsNode a, NodeOf a ~ Node) => String -> Parser a 35 | node name = do 36 | n <- namedToken name $ preview (_Right % nodePrism) 37 | n <$ case preview _NodeCstrSite n of 38 | Just Empty -> do 39 | updateParserState (#stateOffset %~ subtract 1) 40 | registerFailure 41 | (Just . Label $ fromList "an empty construction site") 42 | (one . Label $ fromList name) 43 | _ -> pure () 44 | 45 | anyNode :: Parser Node 46 | anyNode 47 | = choice 48 | [ WhereNode <$> whereClause, DefNode <$> try def, ExprNode <$> expr ] 49 | 50 | term :: Parser Expr 51 | term 52 | = choice 53 | [ surroundOriginalWhitespace 54 | <$> (char '(' *%> fmap noWhitespace expr <*% char ')') 55 | , setWhitespace 56 | <$> choice 57 | [ Node.abstraction' <$% char '\\' <*%> identifier <*% char '=' 58 | <*%> expr 59 | , ifExpression' <$% string "if" <*%> expr <*% string "then" 60 | <*%> expr 61 | <*% string "else" 62 | <*%> expr 63 | -- Non recursive production rules at the bottom 64 | , string "..." >> exprCstrSite' (CstrSite empty) <$% do 65 | updateParserState (#stateOffset %~ subtract 3) 66 | registerFancyFailure . one . ErrorCustom 67 | $ ConsumedEmptyCstrSite "an expression node" 68 | , literal' 69 | <$%> choice 70 | [ Boolean 71 | <$> (True <$ string "True" <|> False <$ string "False") 72 | , Integer <$> decimal 73 | ] 74 | <* notFollowedBy alphaNumChar 75 | , variable' <$%> identifier 76 | ] 77 | , node "an expression node" 78 | ] 79 | where 80 | surroundOriginalWhitespace 81 | (whitespaceFragments, e) = case whitespaceFragments of 82 | [rightFragment, leftFragment] -> e 83 | & exprMeta % #parenthesisLevels +~ 1 84 | & exprMeta % #standardMeta % #interstitialWhitespace 85 | %~ cons leftFragment . flip snoc rightFragment 86 | _ -> error 87 | $ toText ("Unexpected number of whitespace fragments: " 88 | ++ show whitespaceFragments) 89 | 90 | expr :: Parser Expr 91 | expr 92 | = makeExprParser term 93 | $ [ [ InfixL (Application . setWhitespace 94 | <$> try (defaultExprMeta 1 <<$> whitespace 95 | <* notFollowedBy illegalTrailingApplicationTokens)) -- Ugly lookahead to fix problem of succeeding on whitespace between expression and +. Fixable by indentation sensitive parsing, but that requires a TraversableStream instance (or rebuilding the combinators) 96 | ] 97 | , [ Prefix $ unOpParser Negate ] 98 | ] 99 | ++ (binOpParser <<$>> binaryOperatorPrecedence) 100 | where 101 | illegalTrailingApplicationTokens 102 | = choice [ () 103 | <$ choice (map string 104 | $ [ "where", ")", "if", "then", "else" ] 105 | ++ map binaryOperatorSymbol 106 | (concat binaryOperatorPrecedence)) 107 | , () <$ node @WhereClause "" 108 | , () <$ (() <$% identifier <*% char '=') 109 | , () <$ node @Definition "" 110 | , eof 111 | ] 112 | -- parse multiple unary operators in a row in one go. Otherwise it doesn't work for reasons I have yet to figure out 113 | unOpParser unOp = foldr (.) <$> pUnOp <*> many (unOpParser unOp) 114 | where 115 | pUnOp = unaryOperation' unOp <$ string (unaryOperatorSymbol unOp) 116 | binOpParser binOp 117 | = parserAssociativity 118 | (associativity binOp) 119 | (binaryOperation'' binOp . setWhitespace 120 | <$> try (defaultExprMeta 2 <$% pure () 121 | <*% string (binaryOperatorSymbol @String binOp) 122 | <* notFollowedBy (char '=') <*% pure ())) 123 | 124 | parserAssociativity 125 | :: Associativity -> Parser (a -> a -> a) -> Operator Parser a 126 | parserAssociativity = \case 127 | LeftAssociative -> InfixL 128 | RightAssociative -> InfixR 129 | NotAssociative -> InfixN 130 | 131 | def :: Parser Definition 132 | def = setWhitespace <$> literalDef <|> defNode 133 | where 134 | literalDef = Node.def' <$%> identifier <*% char '=' <*%> expr -- <*%> whereClause 135 | defNode = node "a definition node" 136 | 137 | whereClause :: Parser WhereClause 138 | whereClause = whereNode <|> setWhitespace <$> literalWhere -- it's important that whereNode is tried first, because literalWhere succeeds on empty input 139 | where 140 | literalWhere = Node.whereClause' <<$>> (string "where" *%> wSome def) 141 | whereNode = node "a where clause node" 142 | -------------------------------------------------------------------------------- /scout-src/Scout/Parsing/Error.hs: -------------------------------------------------------------------------------- 1 | -- Error formatting helpers copied from megaparsec, but modified for returning Doc's instead of strings 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | 9 | {-# OPTIONS_GHC -Wno-orphans #-} 10 | 11 | module Scout.Parsing.Error where 12 | 13 | import qualified Data.List.NonEmpty as NE 14 | import qualified Data.Set as Set 15 | 16 | import Frugel.DisplayProjection 17 | 18 | import Optics 19 | 20 | import Scout.Node 21 | 22 | import qualified Text.Megaparsec as Megaparsec 23 | import Text.Megaparsec.Error 24 | hiding ( ParseError, errorOffset, parseErrorPretty, parseErrorTextPretty ) 25 | import Text.Megaparsec.Pos 26 | 27 | type ParseError = Megaparsec.ParseError CstrSite ScoutParseError 28 | 29 | newtype ScoutParseError = ConsumedEmptyCstrSite String 30 | deriving ( Eq, Show, Ord ) 31 | 32 | makePrisms ''Megaparsec.ParseError 33 | 34 | makePrisms ''ErrorFancy 35 | 36 | makePrisms ''ScoutParseError 37 | 38 | instance DisplayProjection ParseError where 39 | renderDoc = parseErrorPretty 40 | 41 | errorOffset :: Lens' (Megaparsec.ParseError s e) Int 42 | errorOffset = lens Megaparsec.errorOffset $ flip setErrorOffset 43 | 44 | -- | Pretty-print a 'ParseError'. The rendered 'Doc Annotation ' always ends with a 45 | -- newline. 46 | parseErrorPretty :: ParseError -> Doc Annotation 47 | parseErrorPretty e 48 | = "offset=" 49 | <> show (Megaparsec.errorOffset e) 50 | <> ":" 51 | <> line 52 | <> parseErrorTextPretty e 53 | 54 | -- | Pretty-print a textual part of a 'ParseError', that is, everything 55 | -- except for its position. The rendered 'Doc Annotation ' always ends with a 56 | -- newline. 57 | -- 58 | -- @since 5.1.0 59 | parseErrorTextPretty :: ParseError -> Doc Annotation 60 | parseErrorTextPretty (TrivialError _ us ps) 61 | = if isNothing us && Set.null ps 62 | then "unknown parse error" 63 | else messageItemsPretty 64 | "unexpected" 65 | (showErrorItem 66 | <$> maybe (error "Internal logic error: missing expected item") 67 | one 68 | us) 69 | <> line 70 | <> messageItemsPretty "expecting" 71 | (showErrorItem <$> fromList (toList ps)) 72 | parseErrorTextPretty (FancyError offset xs) 73 | = if Set.null xs 74 | then "unknown fancy parse error" 75 | else vsep (showErrorFancy offset <$> Set.toAscList xs) 76 | 77 | -- | Pretty-print an 'ErrorItem'. 78 | showErrorItem :: ErrorItem (Either Char Node) -> Doc Annotation 79 | showErrorItem = \case 80 | Tokens ts -> renderDoc @CstrSite $ fromFoldable ts 81 | Label label -> pretty $ toList label 82 | EndOfInput -> "end of input" 83 | 84 | -- | Pretty-print an 'ErrorFancy'. 85 | showErrorFancy :: Int -> ErrorFancy ScoutParseError -> Doc Annotation 86 | showErrorFancy offset = \case 87 | ErrorFail msg -> pretty msg 88 | ErrorIndentation ord' ref actual -> "incorrect indentation (got " 89 | <> show (unPos actual) 90 | <> ", should be " 91 | <> p 92 | <> show (unPos ref) 93 | <> ")" 94 | where 95 | p = case ord' of 96 | LT -> "less than " 97 | EQ -> "equal to " 98 | GT -> "greater than " 99 | ErrorCustom (ConsumedEmptyCstrSite nodeName) -> parseErrorTextPretty 100 | $ TrivialError offset 101 | (Just . Label $ fromList "an empty construction site") 102 | (one . Label $ fromList nodeName) 103 | 104 | -- | Transforms a list of error messages into their textual representation. 105 | messageItemsPretty :: 106 | -- | Prefix to prepend 107 | Doc Annotation -> NonEmpty (Doc Annotation) -> Doc Annotation 108 | messageItemsPretty prefix ts | null ts = "" 109 | | otherwise = prefix `nestingLine` orList ts 110 | 111 | -- | Print a pretty list where items are separated with commas and the word 112 | -- “or” according to the rules of English punctuation. 113 | orList :: NonEmpty (Doc Annotation) -> Doc Annotation 114 | orList (x :| []) = x 115 | orList (x :| [y]) = x <> " or " <> y 116 | orList xs 117 | = fillCat (punctuate ", " (toList $ NE.init xs)) <> ", or " <> last xs 118 | -------------------------------------------------------------------------------- /scout-src/Scout/Parsing/Whitespace.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TupleSections #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | module Scout.Parsing.Whitespace where 8 | 9 | import Data.Char 10 | import Data.Has 11 | import qualified Data.Set as Set 12 | 13 | import Optics.Extra.Scout 14 | 15 | import Scout.Node 16 | 17 | import Text.Megaparsec hiding ( some ) 18 | 19 | type WithWhitespace a = ([Text], a) 20 | 21 | whitespaceToken :: (MonadParsec e s m, Token s ~ Either Char Node) => m Text 22 | whitespaceToken = fromMaybe "" <$> optional whitespace' 23 | where 24 | whitespace' 25 | = fmap toText . some . hidden 26 | $ token (leftToMaybe >=> guarded isSpace) Set.empty 27 | 28 | whitespace :: (MonadParsec e s m, Token s ~ Either Char Node) 29 | => m (WithWhitespace ()) 30 | whitespace = (, ()) . one <$> whitespaceToken 31 | 32 | noWhitespace :: a -> WithWhitespace a 33 | noWhitespace a = ([], a) 34 | 35 | setWhitespace :: forall a. Has Meta a => WithWhitespace a -> a 36 | setWhitespace (whitespaceFragments, a) 37 | = a 38 | & (hasLens @Meta @a % #interstitialWhitespace) 39 | .~ reverse whitespaceFragments 40 | 41 | infixl 4 <$%>, <$%, <*%>, <*%, *%> 42 | 43 | (<$%>) :: Functor f => (a -> b) -> f a -> f (WithWhitespace b) 44 | (<$%>) f fa = second f . noWhitespace <$> fa 45 | 46 | (<$%) :: Functor f => a -> f b -> f (WithWhitespace a) 47 | (<$%) a fb = const a <$%> fb 48 | 49 | (<*%>) :: (MonadParsec e s m, Token s ~ Either Char Node) 50 | => m (WithWhitespace (a -> b)) 51 | -> m a 52 | -> m (WithWhitespace b) 53 | (<*%>) ff fa 54 | = (\(whitespaceFragments, f) ws a -> 55 | (ws : whitespaceFragments, f a)) <$> ff <*> whitespaceToken <*> fa 56 | 57 | (<*%) :: (MonadParsec e s m, Token s ~ Either Char Node) 58 | => m (WithWhitespace a) 59 | -> m b 60 | -> m (WithWhitespace a) 61 | (<*%) fa fb = const <<$>> fa <*%> fb 62 | 63 | (*%>) :: (MonadParsec e s m, Token s ~ Either Char Node) 64 | => m a 65 | -> m (WithWhitespace b) 66 | -> m (WithWhitespace b) 67 | (*%>) fa fb = (first . flip snoc) <$ fa <*> whitespaceToken <*> fb 68 | 69 | wSome :: (MonadParsec e s m, Token s ~ Either Char Node) 70 | => m a 71 | -> m (WithWhitespace (NonEmpty a)) 72 | wSome fa = bimap reverse fromList <$> wSome' 73 | where 74 | wSome' 75 | = second . cons <$> fa 76 | <*> (try (first . cons <$> whitespaceToken <*> wSome') 77 | <|> pure (noWhitespace [])) 78 | -- wMany :: (MonadParsec e s m, Token s ~ Either Char Node) 79 | -- => m a 80 | -- -> m (WithWhitespace [a]) 81 | -- wMany fa = toList <<$>> wSome fa <|> pure (noWhitespace []) 82 | -- wOptional 83 | -- :: MonadPlus m => m (WithWhitespace a) -> m (WithWhitespace (Maybe a)) 84 | -- wOptional fa = Just <<$>> fa <|> pure (noWhitespace Nothing) 85 | -------------------------------------------------------------------------------- /scout-src/Scout/PrettyPrinting.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | module Scout.PrettyPrinting where 8 | 9 | import Data.Has 10 | 11 | import Frugel.DisplayProjection 12 | 13 | import Optics.Extra.Scout 14 | 15 | import PrettyPrinting.Expr 16 | 17 | import qualified Scout.Internal.Node 18 | import Scout.Node hiding ( Elided ) 19 | 20 | data PrettyAnnotation = CompletionAnnotation' Node CompletionStatus | Elided' 21 | 22 | toStandardAnnotation :: PrettyAnnotation -> Annotation 23 | toStandardAnnotation (CompletionAnnotation' _ completionStatus) 24 | = CompletionAnnotation completionStatus 25 | toStandardAnnotation Elided' = Elided 26 | 27 | prettyCstrSite :: Node 28 | -> (Node -> Doc PrettyAnnotation) 29 | -> CstrSite 30 | -> Doc PrettyAnnotation 31 | prettyCstrSite n prettyNode 32 | = renderCstrSite' (annotateInConstruction' n) annotateComplete' prettyNode 33 | -- remove leading whitespace on newlines, because indenting is managed by the pretty printer 34 | . fromList @CstrSite 35 | . intercalate [ Left '\n' ] 36 | . map (dropWhile (\c -> c == Left ' ' || c == Left '\t')) 37 | . splitOn (Left '\n') 38 | . toList 39 | 40 | annotateInConstruction' :: Node -> Doc PrettyAnnotation -> Doc PrettyAnnotation 41 | annotateInConstruction' n = annotate $ CompletionAnnotation' n InConstruction 42 | 43 | annotateComplete' :: Node -> Doc PrettyAnnotation -> Doc PrettyAnnotation 44 | annotateComplete' n = annotate $ CompletionAnnotation' n Complete 45 | 46 | class AnnotatedPretty a where 47 | annPretty :: a -> Doc PrettyAnnotation 48 | 49 | instance AnnotatedPretty Node where 50 | annPretty (ExprNode expr) = annPretty expr 51 | annPretty (DefNode def) = annPretty def 52 | annPretty (WhereNode w) = annPretty w 53 | 54 | instance AnnotatedPretty Expr where 55 | annPretty 56 | = stubIfNotEvaluated 57 | . prettyNodeWithMeta 58 | . parenthesizeExprFromMeta parens 59 | $ \expr -> case expr of 60 | Variable _ n -> pretty n 61 | Abstraction _ arg subExp -> backslash 62 | <> pretty arg 63 | `nestingLine` (equals <+> annPretty (prettyUnary expr subExp)) 64 | Application _ function arg -> uncurry nestingLine 65 | $ both %~ annPretty 66 | $ prettyBinary expr function arg 67 | IfExpression _ conditional trueExpr falseExpr -> align 68 | $ vsep [ "if" <+> annPretty conditional 69 | , "then" <+> annPretty trueExpr 70 | , "else" <+> annPretty (prettyUnary expr falseExpr) 71 | ] 72 | UnaryOperation _ unOp subExp -> mappend (unaryOperatorSymbol unOp) 73 | . annPretty 74 | $ prettyUnary expr subExp 75 | BinaryOperation _ left binOp right -> 76 | (\(left', right') -> annPretty left' 77 | `nestingLine` (binaryOperatorSymbol binOp 78 | <+> annPretty right')) 79 | $ prettyBinary expr left right 80 | Literal _ l -> pretty l 81 | ExprCstrSite _ contents -> 82 | prettyCstrSite (ExprNode expr) annPretty contents 83 | where 84 | (prettyUnary, prettyBinary) 85 | = makeExprPrettyPrinter (exprMeta % #parenthesisLevels %~ max 1) 86 | stubIfNotEvaluated prettyNode n 87 | = case n ^. hasLens @ExprMeta % #evaluationStatus of 88 | Evaluated -> prettyNode n 89 | evaluationStatus -> annotate Elided' $ pretty evaluationStatus 90 | 91 | instance AnnotatedPretty Definition where 92 | annPretty = prettyNodeWithMeta $ \case 93 | Def{..} -> pretty name `nestingLine` equals <+> annPretty value 94 | d@(DefCstrSite _ contents) -> 95 | prettyCstrSite (DefNode d) annPretty contents 96 | 97 | -- <> annPretty whereClause 98 | instance AnnotatedPretty WhereClause where 99 | annPretty = prettyNodeWithMeta $ \case 100 | (WhereClause _ defs) -> "where" 101 | <> nest 2 (line <> vsep (map annPretty $ toList defs)) 102 | whereClause@(WhereCstrSite _ contents) -> 103 | prettyCstrSite (WhereNode whereClause) annPretty contents 104 | 105 | prettyNodeWithMeta 106 | :: Has Meta n => (n -> Doc PrettyAnnotation) -> n -> Doc PrettyAnnotation 107 | prettyNodeWithMeta prettyNode n 108 | = if getter @Meta n ^. #elided 109 | then annotate Elided' "..." 110 | else prettyNode n 111 | -------------------------------------------------------------------------------- /scout-src/Scout/Program.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | module Scout.Program 9 | ( module Scout.Program 10 | , Program(Program, ProgramCstrSite) 11 | , ProgramMeta(ProgramMeta) 12 | , _Program 13 | , _ProgramCstrSite 14 | , program' 15 | , programMeta 16 | , programCstrSite' 17 | , unsafePrettyProgram 18 | , enumerateValidProgramMeta 19 | ) where 20 | 21 | import qualified Control.Lens as Lens 22 | 23 | import Data.Constrained 24 | import Data.Data 25 | import Data.Data.Lens 26 | import Data.Dynamic 27 | import Data.Dynamic.Lens as DL 28 | import Data.Has 29 | 30 | import Optics.Extra.Scout as Optics 31 | 32 | import Scout.Internal.Program hiding ( expr, whereClause ) 33 | import Scout.Node 34 | import Scout.Orphans.DisplayProjection () 35 | 36 | class (LabelOptic' "exprMeta" An_AffineFold a ExprMeta, Has Meta a, Data a) 37 | => EvaluatedConstraint a 38 | 39 | instance (LabelOptic' "exprMeta" An_AffineFold a ExprMeta, Has Meta a, Data a) 40 | => EvaluatedConstraint a 41 | 42 | -- I think this mess isn't actually even necessary without evaluation observing rendering of focused expressions, because now it's only used in unsafeEvaluateSelectedNodeValue and we don't care about forcing OutOfFuel source expressions and all other expressions in EvaluationStatus are Hidden 43 | allEvaluatedChildren :: ( HasCallStack 44 | , LabelOptic' "exprMeta" An_AffineFold a ExprMeta 45 | , Has Meta a 46 | , Data a 47 | ) 48 | => Fold a (Constrained EvaluatedConstraint) 49 | allEvaluatedChildren 50 | = to Constrained 51 | % evaluated 52 | % notElided 53 | % Optics.cosmosOf (nodeChildren % evaluated % notElided) 54 | where 55 | notElided :: AffineFold (Constrained EvaluatedConstraint) 56 | (Constrained EvaluatedConstraint) 57 | notElided 58 | = filtered $ fromConstrained (not . view (hasLens @Meta % #elided)) 59 | evaluated :: AffineFold (Constrained EvaluatedConstraint) 60 | (Constrained EvaluatedConstraint) 61 | evaluated = filtered $ fromConstrained predicate 62 | where 63 | predicate 64 | :: (LabelOptic' "exprMeta" An_AffineFold a ExprMeta) => a -> Bool 65 | predicate 66 | = maybe True (== Evaluated) 67 | . preview (#exprMeta % #evaluationStatus) 68 | 69 | nodeChildren :: HasCallStack 70 | => Fold (Constrained EvaluatedConstraint) (Constrained EvaluatedConstraint) 71 | nodeChildren = foldVL nodeChildrenVL 72 | 73 | -- todo: make constraint polymorphic 74 | -- The Constrained should be either Program or a child node 75 | nodeChildrenVL :: HasCallStack 76 | => Lens.Fold (Constrained EvaluatedConstraint) 77 | (Constrained EvaluatedConstraint) 78 | nodeChildrenVL f = _ConstrainedVL $ Lens.re @Dynamic _Dynamic nodeChildren' 79 | where 80 | nodeChildren' d = d <$ case d of 81 | DL.Dynamic (ProgramCstrSite _ cstrSite) -> traverseCstrSite cstrSite 82 | DL.Dynamic program -> traverseOf_ 83 | ((#expr % to Constrained) 84 | `summing` (#whereClause % _Just % to Constrained)) 85 | f 86 | (program :: Program) 87 | DL.Dynamic node -> traverseNode node 88 | DL.Dynamic expr -> traverseExpr expr 89 | DL.Dynamic def -> traverseExpr def 90 | DL.Dynamic whereClause -> traverseExpr whereClause 91 | _ -> error "nodeChildrenVL used on non-Node type" 92 | traverseCstrSite = traverseOf_ (_CstrSite % folded % _Right) $ \case 93 | ExprNode e -> f $ Constrained e 94 | DefNode e -> f $ Constrained e 95 | WhereNode e -> f $ Constrained e 96 | traverseNode = \case 97 | ExprNode e -> traverseExpr e 98 | DefNode d -> traverseDef d 99 | WhereNode w -> traverseWhereClause w 100 | traverseExpr (ExprCstrSite _ cstrSite) = traverseCstrSite cstrSite 101 | traverseExpr expr 102 | = Lens.traverseOf_ (uniplate . Lens.to Constrained) f expr 103 | traverseDef (DefCstrSite _ cstrSite) = traverseCstrSite cstrSite 104 | traverseDef def = traverseOf_ (#value % to Constrained) f def 105 | traverseWhereClause (WhereCstrSite _ cstrSite) = traverseCstrSite cstrSite 106 | traverseWhereClause (WhereClause _ defs) = traverse_ (f . Constrained) defs 107 | -------------------------------------------------------------------------------- /scout-src/Scout/Truncatable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | module Scout.Truncatable where 5 | 6 | import Data.Data.Lens 7 | 8 | import Optics 9 | 10 | import Scout.Node 11 | 12 | class Truncatable a where 13 | truncate :: Int -> a -> a 14 | 15 | instance Truncatable (ACstrSite Node) where 16 | truncate depth cstrSite 17 | = if depth < completeNodesCount 18 | then toCstrSite [ Left "..." ] 19 | else cstrSite 20 | & _CstrSite % mapped % _Right 21 | %~ truncate (depth - completeNodesCount) 22 | where 23 | completeNodesCount = lengthOf (_CstrSite % folded % _Right) cstrSite 24 | 25 | instance Truncatable Node where 26 | truncate depth n = case n of 27 | ExprNode expr -> ExprNode $ truncate depth expr 28 | DefNode def -> DefNode $ truncate depth def 29 | WhereNode whereClause -> WhereNode $ truncate depth whereClause 30 | 31 | instance Truncatable Expr where 32 | truncate depth expr 33 | | depth <= 0 = elideExpr expr -- use evaluation status for expr, because inspecting it's meta forces the constructor 34 | truncate depth (ExprCstrSite meta cstrSite) 35 | = ExprCstrSite meta $ truncate depth cstrSite 36 | truncate depth expr@IfExpression{} 37 | = if depth < 4 38 | then elideExpr expr 39 | else expr & traversalVL uniplate %~ truncate (depth - 4) 40 | truncate depth expr = expr & traversalVL uniplate %~ truncate (pred depth) 41 | 42 | instance Truncatable Definition where 43 | truncate depth def | depth <= 0 = elide def 44 | truncate depth (DefCstrSite meta cstrSite) 45 | = DefCstrSite meta $ truncate depth cstrSite 46 | truncate depth def = def & #value %~ truncate (pred depth) 47 | 48 | instance Truncatable WhereClause where 49 | truncate depth whereClause | depth <= 0 = elide whereClause 50 | truncate depth (WhereCstrSite meta cstrSite) 51 | = WhereCstrSite meta $ truncate depth cstrSite 52 | truncate depth whereClause 53 | = whereClause & _WhereClause % _2 % mapped %~ truncate (pred depth) 54 | -------------------------------------------------------------------------------- /scout-src/Scout/Unbound.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Scout.Unbound where 6 | 7 | import Data.Data.Lens 8 | import qualified Data.Set as Set 9 | 10 | import Optics 11 | 12 | import qualified Scout.Internal.Node 13 | import qualified Scout.Internal.Program 14 | import Scout.Node 15 | import Scout.Program 16 | 17 | class Unbound a where 18 | freeVariables :: Set Identifier -> a -> Set Identifier 19 | 20 | instance Unbound (ACstrSite Node) where 21 | freeVariables env cstrSite 22 | = foldMapOf (_CstrSite % folded % _Right) freeVariables' cstrSite 23 | where 24 | freeVariables' = \case 25 | ExprNode e -> freeVariables newEnv e 26 | DefNode d -> freeVariables newEnv d 27 | WhereNode w -> freeVariables newEnv w 28 | newEnv 29 | = mappend env 30 | . flip (foldMapOf (_CstrSite % folded % _Right)) cstrSite 31 | $ \case 32 | ExprNode _ -> mempty 33 | DefNode d -> foldMapOf #name Set.singleton d 34 | WhereNode w -> fromList $ whereClauseBindees w 35 | 36 | instance Unbound Expr where 37 | freeVariables env = \case 38 | Variable _ n -> if Set.member n env then mempty else Set.singleton n 39 | Abstraction _ n e -> freeVariables (Set.insert n env) e 40 | ExprCstrSite _ cstrSite -> freeVariables env cstrSite 41 | expr -> foldMapOf (traversalVL uniplate) (freeVariables env) expr 42 | 43 | instance Unbound Definition where 44 | freeVariables env Def{..} = freeVariables (Set.insert name env) value 45 | freeVariables env (DefCstrSite _ cstrSite) = freeVariables env cstrSite 46 | 47 | instance Unbound WhereClause where 48 | freeVariables env w@(WhereClause _ defs) 49 | = foldMap (freeVariables $ env <> fromList (whereClauseBindees w)) defs 50 | freeVariables env (WhereCstrSite _ cstrSite) = freeVariables env cstrSite 51 | 52 | instance Unbound Program where 53 | freeVariables env Program{..} 54 | = freeVariables newEnv expr <> foldMap (freeVariables env) whereClause 55 | where 56 | newEnv 57 | = env 58 | <> fromList (whereClause ^.. _Just 59 | % ((_WhereClause % _2 % folded % #name) 60 | `summing` (_WhereCstrSite 61 | % _2 62 | % _CstrSite 63 | % folded 64 | % _Right 65 | % ((_DefNode % #name) 66 | `summing` (_WhereNode 67 | % _WhereClause 68 | % _2 69 | % folded 70 | % #name))))) 71 | freeVariables env (ProgramCstrSite _ cstrSite) = freeVariables env cstrSite 72 | -------------------------------------------------------------------------------- /scout-src/Text/Megaparsec/State/Optics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | {-# OPTIONS_GHC -Wno-orphans #-} 9 | 10 | module Text.Megaparsec.State.Optics where 11 | 12 | import Optics 13 | 14 | import Prelude hiding ( State ) 15 | 16 | import Text.Megaparsec 17 | 18 | makeFieldLabels ''State 19 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { sources ? import ./nix/sources.nix { } 2 | , ghc ? "ghc8107" 3 | }: 4 | let 5 | haskellNix = import sources.haskellNix { }; 6 | pkgs = import haskellNix.sources.nixpkgs-unstable haskellNix.nixpkgsArgs; 7 | 8 | hsPkgs = import ./base.nix { inherit pkgs ghc; }; 9 | 10 | floskell = ( 11 | pkgs.haskell-nix.hackage-package 12 | { 13 | compiler-nix-name = ghc; 14 | name = "floskell"; 15 | version = "latest"; 16 | modules = [ 17 | { 18 | packages.floskell.ghcOptions = [ "-threaded" "-with-rtsopts=-N" ]; 19 | } 20 | ]; 21 | } 22 | ).components.exes.floskell; 23 | 24 | nix-pre-commit-hooks = import "${sources."pre-commit-hooks.nix"}/nix" { nixpkgs = haskellNix.sources.nixpkgs-unstable; }; 25 | pre-commit-check = nix-pre-commit-hooks.run { 26 | src = ./.; 27 | hooks = with import ./nix/commit-hooks.nix { inherit pkgs floskell; }; { 28 | nixpkgs-fmt.enable = true; 29 | nix-linter.enable = true; 30 | hlint.enable = true; 31 | prettier = { 32 | enable = true; 33 | files = "www/.*\\.css|.*\\.md$"; 34 | }; 35 | floskell = floskellHook // { 36 | enable = true; 37 | }; 38 | build = buildHook // { 39 | enable = true; 40 | }; 41 | floskellConfigChange = floskellConfigChangeHook // { 42 | enable = true; 43 | }; 44 | weeder = weederHook // { 45 | enable = true; 46 | }; 47 | }; 48 | }; 49 | in 50 | hsPkgs.shellFor { 51 | tools = { 52 | cabal = "3.4.0.0"; 53 | hlint = "latest"; 54 | stan = "latest"; 55 | }; 56 | buildInputs = with pkgs; [ 57 | floskell 58 | ghcid 59 | stack 60 | git # required by pre-commit-check shell hook 61 | dhall-lsp-server 62 | ( 63 | pkgs.haskell-nix.hackage-package 64 | { 65 | compiler-nix-name = ghc; 66 | name = "weeder"; 67 | version = "2.2.0"; 68 | } 69 | ).components.exes.weeder 70 | ( 71 | pkgs.haskell-nix.hackage-package 72 | { 73 | compiler-nix-name = ghc; 74 | name = "apply-refact"; 75 | version = "latest"; 76 | } 77 | ).components.exes.refactor 78 | ( 79 | pkgs.haskell-nix.hackage-package 80 | { 81 | compiler-nix-name = ghc; 82 | name = "haskell-language-server"; 83 | version = "latest"; 84 | configureArgs = "-frename --allow-newer=hls-rename-plugin:ghcide"; 85 | } 86 | ).components.exes.haskell-language-server 87 | ] ++ builtins.attrValues (import ./nix/scripts.nix { inherit pkgs floskell; }); 88 | withHoogle = false; 89 | exactDeps = false; 90 | shellHook = '' 91 | ${pre-commit-check.shellHook} 92 | ''; 93 | STACK_YAML = "nix-stack.yaml"; 94 | } 95 | -------------------------------------------------------------------------------- /src/Control/Zipper/Seq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | module Control.Zipper.Seq where 12 | 13 | import qualified Data.Sequence as Seq 14 | 15 | import Optics.Extra.Frugel 16 | 17 | data SeqZipper a = SeqZipper { reversedPrefix :: Seq a, suffix :: Seq a } 18 | deriving ( Eq ) 19 | 20 | makeFieldLabelsNoPrefix ''SeqZipper 21 | 22 | unzipTo :: Int -> Seq a -> Maybe (SeqZipper a) 23 | unzipTo i xs | 0 <= i && i <= length xs, (prefix, suffix) <- Seq.splitAt i xs 24 | = Just SeqZipper { reversedPrefix = Seq.reverse prefix, .. } 25 | unzipTo _ _ = Nothing 26 | 27 | rezip :: SeqZipper a -> Seq a 28 | rezip SeqZipper{..} = Seq.reverse reversedPrefix <> suffix 29 | 30 | insert :: a -> SeqZipper a -> SeqZipper a 31 | insert x = #suffix %~ cons x 32 | 33 | -- prefixTail :: SeqZipper a -> Maybe (SeqZipper a) 34 | -- prefixTail = #reversedPrefix %%~ preview _tail 35 | suffixTail :: SeqZipper a -> Maybe (SeqZipper a) 36 | suffixTail = #suffix %%~ preview _tail 37 | -------------------------------------------------------------------------------- /src/Frugel.hs: -------------------------------------------------------------------------------- 1 | module Frugel 2 | ( module Frugel.Model 3 | , module Frugel.Error 4 | , module Frugel.Action 5 | , module Frugel.Decomposition 6 | , module Frugel.DisplayProjection 7 | , module Frugel.Parsing 8 | , module Frugel.CstrSite 9 | , Model(Model, program, cursorOffset, errors) 10 | ) where 11 | 12 | import Frugel.Action 13 | import Frugel.CstrSite 14 | import Frugel.Decomposition hiding ( ModificationStatus(..) ) 15 | import Frugel.DisplayProjection 16 | import Frugel.Error 17 | import qualified Frugel.Internal.Model 18 | import Frugel.Model 19 | import Frugel.Parsing 20 | -------------------------------------------------------------------------------- /src/Frugel/Action.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TupleSections #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | module Frugel.Action where 9 | 10 | import Control.Lens.Plated 11 | import Control.Zipper.Seq hiding ( insert ) 12 | import qualified Control.Zipper.Seq as SeqZipper 13 | 14 | import Data.Data 15 | import Data.Data.Lens 16 | import Data.Sequence.Optics 17 | import qualified Data.Set as Set 18 | 19 | import Frugel.CstrSite 20 | import Frugel.Decomposition hiding ( ModificationStatus(..) ) 21 | import Frugel.DisplayProjection 22 | import Frugel.Error 23 | import qualified Frugel.Internal.Model 24 | import Frugel.Model 25 | import Frugel.Parsing 26 | import Frugel.PrettyPrinting hiding ( prettyPrint ) 27 | import qualified Frugel.PrettyPrinting as PrettyPrinting 28 | 29 | import Optics.Extra.Frugel 30 | 31 | import Prettyprinter.Render.String 32 | 33 | data EditResult = Success | Failure 34 | deriving ( Show, Eq ) 35 | 36 | data Direction = Leftward | Rightward | Upward | Downward 37 | deriving ( Show, Eq ) 38 | 39 | data GenericAction = Insert Char | Delete | Backspace | Move Direction 40 | deriving ( Show, Eq ) 41 | 42 | class ( Data p 43 | , Data (NodeOf p) 44 | , Decomposable p 45 | , Decomposable (NodeOf p) 46 | , CstrSiteNode p 47 | , CstrSiteNode (NodeOf p) 48 | , Parseable p 49 | ) => Editable p 50 | 51 | updateModel :: forall p. 52 | (Editable p, DisplayProjection p) 53 | => GenericAction 54 | -> Model p 55 | -> (EditResult, Model p) 56 | updateModel (Insert c) model = insert c model 57 | updateModel Delete model = delete model 58 | updateModel Backspace model = backspace model 59 | updateModel (Move direction) model = moveCursor direction model 60 | 61 | insert :: Editable p => Char -> Model p -> (EditResult, Model p) 62 | insert c model = case editResult of 63 | Success -> edited & _2 % #cursorOffset +~ 1 64 | Failure -> edited 65 | where 66 | edited@(editResult, _) 67 | = attemptEdit (zipperAtCursor (Just . SeqZipper.insert (Left c)) 68 | $ view #cursorOffset model) 69 | model 70 | 71 | delete :: Editable p => Model p -> (EditResult, Model p) 72 | delete model@Model{..} = case editResult of 73 | Success -> edited 74 | Failure -> edited & _2 % #errors .~ errors 75 | where 76 | edited@(editResult, _) 77 | = attemptEdit 78 | (zipperAtCursor 79 | (suffixTail <=< guarded (is $ #suffix % ix 0 % _Left)) 80 | cursorOffset) 81 | model 82 | 83 | backspace :: Editable p => Model p -> (EditResult, Model p) 84 | 85 | -- when the bad default of "exiting" after a node when transformation failed is fixed 86 | -- backspace model 87 | -- = case attemptEdit 88 | -- (zipperAtCursor prefixTail $ view #cursorOffset model) 89 | -- model of 90 | -- (Success, newModel) -> newModel & #cursorOffset -~ 1 91 | -- (Failure, newModel) -> newModel & #errors .~ [] 92 | backspace model 93 | | view #cursorOffset model > 0 94 | = attemptEdit 95 | (zipperAtCursor 96 | (suffixTail <=< guarded (is $ #suffix % ix 0 % _Left)) 97 | (view #cursorOffset model - 1)) 98 | $ over #cursorOffset (subtract 1) model 99 | backspace model = (Failure, model) 100 | 101 | moveCursor 102 | :: DisplayProjection p => Direction -> Model p -> (EditResult, Model p) 103 | moveCursor direction model@Model{..} 104 | = ( if cursorOffset == newOffset then Failure else Success 105 | , model & #cursorOffset .~ newOffset 106 | ) 107 | where 108 | newOffset = updateOffset cursorOffset 109 | updateOffset = case direction of 110 | Leftward -> max 0 . subtract 1 111 | Rightward -> min (length programText) . (+ 1) 112 | -- extra subtract 1 for the \n 113 | Upward -> case leadingLines of 114 | ((_ :> previousLine) :> leadingChars) -> max 0 115 | . subtract (length leadingChars -- rest of the current line 116 | + 1 -- \n 117 | + max 0 (length previousLine - length leadingChars)) -- end of or same column on the previous line 118 | _ -> const currentOffset 119 | Downward -> case (leadingLines, trailingLines) of 120 | (_ :> leadingChars, trailingChars : (nextLine : _)) -> min 121 | (length programText) 122 | . (length trailingChars -- rest of the current line 123 | + 1 -- \n 124 | + min (length nextLine) (length leadingChars) +) -- end of or same column on the next line 125 | _ -> const currentOffset 126 | (leadingLines, trailingLines) 127 | = splitAt currentOffset programText & both %~ splitOn '\n' 128 | currentOffset = view #cursorOffset model 129 | -- uses layoutPretty for consistency with view 130 | programText 131 | = renderString . layoutPretty defaultLayoutOptions $ renderDoc program 132 | 133 | prettyPrint :: (Editable p, PrettyPrint p) => Model p -> Model p 134 | prettyPrint model@Model{..} 135 | = model 136 | & #program .~ newProgram 137 | & #errors .~ map ParseError newErrors 138 | & #cursorOffset .~ min cursorOffset (textLength newProgram) 139 | where 140 | (newProgram, newErrors) = PrettyPrinting.prettyPrint program 141 | 142 | attemptEdit :: forall p. 143 | Editable p 144 | => (p -> Either (InternalError p) p) 145 | -> Model p 146 | -> (EditResult, Model p) 147 | attemptEdit 148 | f 149 | model = case second (reparse programParser) . f $ view #program model of 150 | Left editError -> (Failure, model & #errors .~ [ InternalError editError ]) 151 | Right (newProgram, newErrors) -> 152 | ( Success 153 | , model 154 | & #program .~ flattenConstructionSites newProgram 155 | & #errors .~ map ParseError (toList newErrors) 156 | & #cursorOffset 157 | %~ subtract 158 | (consumedEmptyCstrSiteCount @p (toList newErrors, newProgram) * 3) 159 | ) 160 | where 161 | reparse :: forall n. 162 | (NodeOf p ~ NodeOf n, Data n, Decomposable n) 163 | => (ParserOf p) n 164 | -> n 165 | -> (n, Set (ParseErrorOf p)) 166 | reparse parser node 167 | = (\((newNode, nodeParseErrors), nestedParseErrors) -> 168 | (newNode, nodeParseErrors <> nestedParseErrors)) 169 | . first (reparseNestedCstrSites @p reparse 170 | . fromMaybe (decompose node, node)) 171 | . findSuccessfulParse 172 | . groupSortOn cstrSiteCount 173 | . inliningVariations 174 | $ decompose node 175 | where 176 | findSuccessfulParse = foldl' collectResults (Nothing, mempty) 177 | collectResults firstSuccessfulParse@(Just _, _) _ 178 | = firstSuccessfulParse 179 | collectResults (Nothing, errors) cstrSiteBucket = case rights parses of 180 | -- Only count success if it's the only one to be conservative in the presence of ambiguity 181 | [(cstrSite, (recoveredErrors, newNode))] -> 182 | ( Just (cstrSite, newNode) 183 | , newErrors <> fromList recoveredErrors 184 | ) 185 | _ -> (Nothing, newErrors) 186 | where 187 | newErrors 188 | = Set.union errors . Set.unions . fmap fromFoldable 189 | $ lefts parses 190 | parses = map (\cstrSite -> second 191 | ( CstrSite 192 | $ seqOf (_CstrSite 193 | % folded 194 | % (filtered isLeft `failing` _Right 195 | % to decompose 196 | % _CstrSite 197 | % folded)) 198 | cstrSite 199 | , 200 | ) 201 | $ runParser @p parser cstrSite) cstrSiteBucket 202 | 203 | flattenConstructionSites :: forall n. 204 | ( Data n 205 | , Typeable (NodeOf n) 206 | , Data (NodeOf n) 207 | , CstrSiteNode (NodeOf n) 208 | , NodeOf n ~ NodeOf (NodeOf n) 209 | ) 210 | => n 211 | -> n 212 | flattenConstructionSites 213 | = transformOnOf (template @n @(ACstrSite (NodeOf n))) uniplate 214 | $ foldMapOf (_CstrSite % folded) 215 | (\item -> fromMaybe (one item) (item ^? _Right % _NodeCstrSite)) 216 | 217 | inliningVariations :: (n ~ NodeOf n, CstrSiteNode n, Decomposable n) 218 | => ACstrSite n 219 | -> [ACstrSite n] 220 | inliningVariations = foldr addItem [ fromList [] ] . view _CstrSite 221 | where 222 | addItem item@(Left _) variations = cons item <$> variations 223 | -- It would be more efficient to have the node's inlining variations also saved in the variation where the node's construction site is not inlined 224 | -- (it's now recomputed in `reparseNestedConstructionSites`) 225 | addItem item@(Right node) variations 226 | = (if is _NodeCstrSite node then cons item <$> variations else mempty) 227 | <> (mappend <$> inliningVariations (decompose node) <*> variations) 228 | 229 | type CstrSiteZipper n = SeqZipper (Either Char (NodeOf n)) 230 | 231 | zipperAtCursor :: (Decomposable p, CstrSiteNode p) 232 | => (CstrSiteZipper p -> Maybe (CstrSiteZipper p)) 233 | -> Int 234 | -> p 235 | -> Either (InternalError p) p 236 | zipperAtCursor f = traverseNodeAt $ \cstrSiteOffset components -> maybeToRight 237 | (CstrSiteActionFailed cstrSiteOffset components) 238 | $ traverseOf _CstrSite (rezip <.> f <=< unzipTo cstrSiteOffset) components 239 | -------------------------------------------------------------------------------- /src/Frugel/CstrSite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | module Frugel.CstrSite where 14 | 15 | import qualified Control.Lens as Lens 16 | import Control.Lens.Plated 17 | 18 | import Data.Data 19 | import Data.Data.Lens 20 | 21 | import Optics 22 | 23 | type family NodeOf a :: Type 24 | 25 | class (NodePrism a, CstrSiteNode a) => IsNode a 26 | 27 | class NodePrism a where 28 | nodePrism :: Prism' (NodeOf a) a 29 | 30 | class CstrSiteNode a where 31 | setCstrSite :: ACstrSite (NodeOf a) -> a -> a 32 | _NodeCstrSite :: AffineTraversal' a (ACstrSite (NodeOf a)) 33 | 34 | newtype ACstrSite n = CstrSite (Seq (Either Char n)) 35 | deriving ( Eq, Ord, Show, Generic, Data ) 36 | deriving newtype ( One, IsList, Semigroup, Monoid ) 37 | 38 | type instance NodeOf (ACstrSite a) = a 39 | 40 | makePrisms ''ACstrSite 41 | 42 | instance Cons (ACstrSite n) (ACstrSite n) (Either Char n) (Either Char n) where 43 | _Cons = _CstrSite % _Cons % aside (re _CstrSite) 44 | 45 | instance Snoc (ACstrSite n) (ACstrSite n) (Either Char n) (Either Char n) where 46 | _Snoc = _CstrSite % _Snoc % swapped % aside (re _CstrSite) % swapped 47 | 48 | instance Eq n => AsEmpty (ACstrSite n) 49 | 50 | -- concatCstrSite :: [CstrSite] -> CstrSite 51 | -- concatCstrSite = CstrSite . join . fromList . map (view _CstrSite) 52 | cstrSiteCount :: Data n => ACstrSite n -> Int 53 | cstrSiteCount = Lens.lengthOf $ cosmosOf uniplate 54 | -------------------------------------------------------------------------------- /src/Frugel/Decomposition.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE MultiWayIf #-} 7 | {-# LANGUAGE QuantifiedConstraints #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | 14 | module Frugel.Decomposition 15 | ( Decomposition 16 | , Decomposable(..) 17 | , ModificationStatus(..) 18 | , _Success 19 | , _Todo 20 | , initialDecompositionState 21 | , textLength 22 | , decompose 23 | , traverseNodeAt 24 | , traverseChildNodeAt 25 | , runDecomposition 26 | ) where 27 | 28 | import Control.Monad.Except 29 | 30 | import Frugel.CstrSite 31 | import Frugel.Error.InternalError 32 | import Frugel.Internal.DecompositionState 33 | 34 | import Optics.Extra.Frugel 35 | 36 | class NodeOf n ~ NodeOf (NodeOf n) => Decomposable n where 37 | -- It would make sense for this function to have a mapKeyword :: Text -> f () and mapWhitespace :: Char -> f Char as well, but it's not yet needed 38 | -- traverseComponents could be generalised to a Bitraversal which might make implementation easier, but at the moment there is no library to work with them so I'm not sure 39 | traverseComponents :: Applicative f 40 | => (Char -> f Char) 41 | -> (forall n'. 42 | (Decomposable n', IsNode n', NodeOf n ~ NodeOf n') 43 | => n' 44 | -> f n') 45 | -> n 46 | -> f n 47 | -- Preserves node when cursor is at start or end. Primarily useful for nodes starting or ending with a character (e.g. lambda and parenthesis). 48 | conservativelyDecompose :: Int -> n -> Maybe (Int, ACstrSite (NodeOf n)) 49 | default conservativelyDecompose 50 | :: NodePrism n => Int -> n -> Maybe (Int, ACstrSite (NodeOf n)) 51 | conservativelyDecompose cstrSiteOffset n = case cstrSiteOffset of 52 | 0 -> Just (0, singletonCstrSite) 53 | l | l == length (toList $ decompose n) -> Just (1, singletonCstrSite) 54 | _ -> Nothing 55 | where 56 | singletonCstrSite = fromList [ Right $ review nodePrism n ] 57 | 58 | instance (Decomposable n, IsNode n, n ~ NodeOf n) 59 | => Decomposable (ACstrSite n) where 60 | conservativelyDecompose _ _ = Nothing 61 | traverseComponents traverseChar' traverseNode' 62 | = traverseOf (_CstrSite % traversed) 63 | $ bitraverse traverseChar' traverseNode' 64 | 65 | decompose :: Decomposable n => n -> ACstrSite (NodeOf n) 66 | decompose n 67 | = fromList . reverse 68 | $ execState 69 | (traverseComponents (conses Left) (conses (Right . review nodePrism)) n) 70 | [] 71 | where 72 | conses f x = x <$ modify (f x :) 73 | 74 | textLength :: (Decomposable n, Decomposable (NodeOf n)) => n -> Int 75 | textLength = sum . either (const 1) textLength <.> view _CstrSite . decompose 76 | 77 | step :: MonadState DecompositionState m => m () 78 | step = do 79 | textOffset <- use #textOffset 80 | -- c <- guse #cstrSiteOffset 81 | -- traceM ("step t: " <> show textOffset <> " c: " <> show c) 82 | when (textOffset /= -1) (#textOffset -= 1) 83 | when (textOffset > 0) (#cstrSiteOffset += 1) 84 | 85 | traverseNodeAt :: forall m p. 86 | (MonadError (InternalError p) m, Decomposable p, CstrSiteNode p) 87 | => (Int -> ACstrSite (NodeOf p) -> m (ACstrSite (NodeOf p))) 88 | -> Int 89 | -> p 90 | -> m p 91 | traverseNodeAt f cursorOffset program 92 | = runDecomposition cursorOffset 93 | (traverseNode @CstrSiteNode transform program) 94 | where 95 | transform :: (Decomposable n, CstrSiteNode n, NodeOf n ~ NodeOf p) 96 | => n 97 | -> Decomposition m n 98 | transform n = do 99 | cstrSiteOffset <- use #cstrSiteOffset 100 | lift 101 | $ flip setCstrSite n 102 | <$> case conservativelyDecompose cstrSiteOffset n of 103 | Just (cstrSiteOffset', cstrSite) -> f cstrSiteOffset' cstrSite 104 | `catchError` const (f cstrSiteOffset $ decompose n) 105 | _ -> f cstrSiteOffset $ decompose n 106 | 107 | traverseChildNodeAt :: forall m p. 108 | (MonadError (InternalError p) m, Decomposable p) 109 | => (forall n. (NodeOf n ~ NodeOf p, IsNode n) => Int -> n -> m n) 110 | -> Int 111 | -> p 112 | -> m p 113 | traverseChildNodeAt f cursorOffset program 114 | = runDecomposition cursorOffset 115 | (traverseComponents traverseChar 116 | (traverseNode @IsNode transform) 117 | program) 118 | where 119 | transform :: (NodeOf n ~ NodeOf p, IsNode n) => n -> Decomposition m n 120 | transform n = do 121 | cstrSiteOffset <- use #cstrSiteOffset 122 | lift $ f cstrSiteOffset n 123 | 124 | runDecomposition :: MonadError (InternalError p) m 125 | => Int 126 | -> StateT DecompositionState m b 127 | -> m b 128 | runDecomposition cursorOffset decomposition 129 | = runStateT decomposition (initialDecompositionState cursorOffset) 130 | >>= \(x, finalState) -> 131 | if | view #textOffset finalState 132 | > 0 -> throwError $ DecompositionFailed cursorOffset 133 | | Todo <- view #modificationStatus finalState -> 134 | throwError $ ASTModificationNotPerformed cursorOffset 135 | | otherwise -> pure x 136 | 137 | traverseChar :: MonadState DecompositionState f => a -> f a 138 | traverseChar c = c <$ step -- trace (show c) step 139 | 140 | traverseNode :: forall (c :: Type 141 | -> Constraint) m e n. 142 | ( MonadError e m 143 | , MonadState DecompositionState m 144 | , Decomposable n 145 | , c n 146 | , forall n'. 147 | IsNode n' 148 | => c n' 149 | ) 150 | => (forall n'. (Decomposable n', c n', NodeOf n' ~ NodeOf n) => n' -> m n') 151 | -> n 152 | -> m n 153 | traverseNode f n 154 | = 155 | -- do 156 | -- t <- guse #textOffset 157 | -- traceM ("pre " <> take 20 (show n) <> " " <> show t) 158 | ifM (guses #textOffset (< 0)) (pure n) -- node is located after cursor 159 | $ do 160 | #cstrSiteOffset 161 | += 1 -- At the moment, the construction site offset passed to `f` is immediately after a node where applying `f` failed. This is not a good default. 162 | withLocal #cstrSiteOffset 0 $ do 163 | newNode <- traverseComponents traverseChar (traverseNode @c f) n 164 | -- t <- guse #textOffset 165 | -- c <- guse #cstrSiteOffset 166 | -- traceM 167 | -- ("post " 168 | -- <> take 20 (show n) 169 | -- <> " t: " 170 | -- <> show t 171 | -- <> " c: " 172 | -- <> show c) 173 | ifM (guses #textOffset (<= 0) 174 | &&^ guses #modificationStatus (isn't _Success)) 175 | ((f n <* assign #modificationStatus Success) 176 | `catchError` const (pure n)) 177 | (pure newNode) 178 | -------------------------------------------------------------------------------- /src/Frugel/DisplayProjection.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | module Frugel.DisplayProjection 9 | ( module Frugel.DisplayProjection 10 | , module Prettyprinter 11 | ) where 12 | 13 | import Data.Data 14 | 15 | import Frugel.CstrSite 16 | import Frugel.Decomposition 17 | import Frugel.Error.InternalError 18 | 19 | import Optics.Extra.Frugel 20 | 21 | import Prettyprinter 22 | import Prettyprinter.Internal.Type ( Doc(Union) ) 23 | 24 | data CompletionStatus = InConstruction | Complete 25 | deriving ( Show, Eq, Data ) 26 | 27 | data Annotation 28 | = CompletionAnnotation CompletionStatus 29 | | Cursor -- Cursor is only supposed to be inserted into SimpleDocStream before rendering. Any contents will be discarded. 30 | | Elided -- See comment on elided field of Meta 31 | deriving ( Show, Eq, Data ) 32 | 33 | annotateInConstruction, annotateComplete :: Doc Annotation -> Doc Annotation 34 | annotateInConstruction = annotate $ CompletionAnnotation InConstruction 35 | 36 | annotateComplete = annotate $ CompletionAnnotation Complete 37 | 38 | class DisplayProjection a where 39 | renderDoc :: a -> Doc Annotation 40 | default renderDoc 41 | :: (Decomposable a, CstrSiteNode a, DisplayProjection (NodeOf a)) 42 | => a 43 | -> Doc Annotation 44 | renderDoc = defaultRenderDoc 45 | 46 | instance DisplayProjection (NodeOf p) 47 | => DisplayProjection (InternalError p) where 48 | renderDoc = \case 49 | ASTModificationNotPerformed cursorOffset -> 50 | "AST was not modified. Cursor offset:" <+> show cursorOffset 51 | DecompositionFailed cursorOffset -> 52 | "failed to decompose AST for cursor offset" <+> show cursorOffset 53 | CstrSiteActionFailed cstrSiteOffset cstrSite -> 54 | "failed to modify the construction site" 55 | `nestingLine` renderDoc cstrSite 56 | <> line 57 | <> "at index" 58 | <+> show cstrSiteOffset 59 | 60 | instance DisplayProjection n => DisplayProjection (ACstrSite n) where 61 | renderDoc = renderCstrSite renderDoc 62 | 63 | defaultRenderDoc 64 | :: (Decomposable s, DisplayProjection (NodeOf s), CstrSiteNode s) 65 | => s 66 | -> Doc Annotation 67 | defaultRenderDoc x 68 | = maybe (renderDecomposable x) (renderCstrSite renderDoc) 69 | $ preview _NodeCstrSite x 70 | 71 | renderDecomposable 72 | :: (Decomposable a, DisplayProjection (NodeOf a)) => a -> Doc Annotation 73 | renderDecomposable 74 | = foldMap (either pretty renderDoc) . view _CstrSite . decompose 75 | 76 | renderCstrSite :: (n -> Doc Annotation) -> ACstrSite n -> Doc Annotation 77 | renderCstrSite 78 | = renderCstrSite' annotateInConstruction (const annotateComplete) 79 | 80 | -- Invariant: renderCstrSite of a non-empty Seq results in a non-empty Doc 81 | renderCstrSite' :: (Doc a -> Doc a) 82 | -> (n -> Doc a -> Doc a) 83 | -> (n -> Doc a) 84 | -> ACstrSite n 85 | -> Doc a 86 | renderCstrSite' inConstruction complete prettyNode (CstrSite contents) 87 | = inConstruction 88 | . foldMap (either pretty (\n -> complete n $ prettyNode n)) 89 | $ toList contents 90 | 91 | nestingLine :: Doc ann -> Doc ann -> Doc ann 92 | nestingLine x y = x <> Union (pretty ' ' <> y) (nest 4 $ line <> y) 93 | -------------------------------------------------------------------------------- /src/Frugel/Error.hs: -------------------------------------------------------------------------------- 1 | module Frugel.Error 2 | ( module Frugel.Error 3 | , module Frugel.Error.InternalError 4 | ) where 5 | 6 | import Frugel.Error.InternalError 7 | import Frugel.Parsing 8 | 9 | data Error p = ParseError (ParseErrorOf p) | InternalError (InternalError p) 10 | -------------------------------------------------------------------------------- /src/Frugel/Error/InternalError.hs: -------------------------------------------------------------------------------- 1 | module Frugel.Error.InternalError where 2 | 3 | import Frugel.CstrSite 4 | 5 | data InternalError p 6 | = ASTModificationNotPerformed Int 7 | | DecompositionFailed Int 8 | | CstrSiteActionFailed Int (ACstrSite (NodeOf p)) -------------------------------------------------------------------------------- /src/Frugel/Internal/DecompositionState.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | module Frugel.Internal.DecompositionState 10 | ( ModificationStatus(..) 11 | , DecompositionState(DecompositionState) 12 | , Decomposition 13 | , initialDecompositionState 14 | , _Todo 15 | , _Success 16 | ) where 17 | 18 | import Optics.Extra.Frugel 19 | 20 | data ModificationStatus = Todo | Success 21 | deriving ( Show, Eq ) 22 | 23 | -- A text offset of -1 is used for representing that we are done with parsing 24 | -- because 0 could also mean we are at the start of a node that still needs to be decomposed 25 | data DecompositionState 26 | = DecompositionState { textOffset :: Int 27 | , cstrSiteOffset :: Int 28 | , modificationStatus :: ModificationStatus 29 | } 30 | deriving ( Show ) 31 | 32 | type Decomposition m = StateT DecompositionState m 33 | 34 | makePrisms ''ModificationStatus 35 | 36 | makeFieldLabelsNoPrefix ''DecompositionState 37 | 38 | initialDecompositionState :: Int -> DecompositionState 39 | 40 | initialDecompositionState textOffset 41 | = DecompositionState { cstrSiteOffset = 0, modificationStatus = Todo, .. } 42 | -------------------------------------------------------------------------------- /src/Frugel/Internal/Model.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | {-# OPTIONS_GHC -Wno-unused-top-binds #-} 9 | 10 | module Frugel.Internal.Model where 11 | 12 | import Frugel.Error 13 | 14 | import Optics 15 | 16 | data Model p = Model { cursorOffset :: Int, program :: p, errors :: [Error p] } 17 | 18 | makeFieldLabelsNoPrefix ''Model -------------------------------------------------------------------------------- /src/Frugel/Model.hs: -------------------------------------------------------------------------------- 1 | module Frugel.Model ( module Frugel.Model, Model(Model) ) where 2 | 3 | import Frugel.Internal.Model 4 | 5 | initialModel :: p -> Model p 6 | initialModel initialProgram 7 | = Model { program = initialProgram, cursorOffset = 0, errors = [] } 8 | -------------------------------------------------------------------------------- /src/Frugel/Parsing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | module Frugel.Parsing where 8 | 9 | import qualified Control.Lens as Lens 10 | import Control.Monad.Writer.Strict 11 | 12 | import Data.Data 13 | import Data.Data.Lens 14 | import qualified Data.Sequence as Seq 15 | import Data.Set.Optics 16 | 17 | import Frugel.CstrSite 18 | import Frugel.Decomposition 19 | 20 | import Optics.Extra.Frugel 21 | 22 | class Ord (ParseErrorOf p) => Parseable p where 23 | type ParserOf p :: Type -> Type 24 | type ParseErrorOf p :: Type 25 | programParser :: (ParserOf p) p 26 | anyNodeParser :: (ParserOf p) (NodeOf p) 27 | runParser :: (ParserOf p) n 28 | -> ACstrSite (NodeOf p) 29 | -> Either (NonEmpty (ParseErrorOf p)) ([ParseErrorOf p], n) 30 | errorOffset :: Lens' (ParseErrorOf p) Int 31 | consumedEmptyCstrSiteCount :: ([ParseErrorOf p], n) -> Int 32 | 33 | fixErrorOffset :: forall p. 34 | (Decomposable (NodeOf p), NodeOf p ~ NodeOf (NodeOf p), Parseable p) 35 | => ACstrSite (NodeOf p) 36 | -> ParseErrorOf p 37 | -> ParseErrorOf p 38 | fixErrorOffset (CstrSite components) = errorOffset @p %~ \offset -> offset 39 | + sumOf (folded % _Right % to (pred . textLength)) 40 | (Seq.take (offset - 1) components) 41 | 42 | reparseNestedCstrSites :: forall p n. 43 | ( Data n 44 | , Typeable (NodeOf n) 45 | , Decomposable n 46 | , Decomposable (NodeOf n) 47 | , NodeOf p ~ NodeOf n 48 | , Parseable p 49 | ) 50 | => (ParserOf p (NodeOf n) -> NodeOf n -> (NodeOf n, Set (ParseErrorOf p))) 51 | -> (ACstrSite (NodeOf p), n) 52 | -> (n, Set (ParseErrorOf p)) 53 | reparseNestedCstrSites reparse (cstrSite, newNode) 54 | = runWriter 55 | $ Lens.itraverseOf 56 | (Lens.indexing $ template @n @(NodeOf n)) 57 | (\i -> 58 | writer . second (increaseErrorOffsets i) . reparse (anyNodeParser @p)) 59 | newNode 60 | where 61 | increaseErrorOffsets i 62 | = setmapped % errorOffset @p 63 | +~ fst 64 | (Seq.filter (isRight . snd) (leadingCumulativeTextLengths cstrSite) 65 | `Seq.index` i) 66 | -- not exactly a prefix sum; first element of pair is text length of construction components before the item in the right element 67 | leadingCumulativeTextLengths (CstrSite components) 68 | = snd 69 | $ mapAccumL 70 | (\l item -> (l + either (const 1) textLength item, (l, item))) 71 | 0 72 | components 73 | -------------------------------------------------------------------------------- /src/Frugel/PrettyPrinting.hs: -------------------------------------------------------------------------------- 1 | module Frugel.PrettyPrinting where 2 | 3 | import Frugel.Parsing 4 | 5 | class PrettyPrint p where 6 | prettyPrint :: p -> (p, [ParseErrorOf p]) 7 | -------------------------------------------------------------------------------- /src/Optics/Extra/Frugel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | module Optics.Extra.Frugel 6 | ( module Optics 7 | , module Optics.Extra.Frugel 8 | , module Optics.State.Operators 9 | ) where 10 | 11 | import Optics 12 | import Optics.State.Operators 13 | 14 | infixr 4 %%~, +~, -~, %@~ 15 | 16 | infix 4 +=, -= 17 | 18 | (+~) :: (Num a, Is k A_Setter) => Optic k is s t a a -> a -> s -> t 19 | l +~ n = over l (+ n) 20 | 21 | (-~) :: (Num a, Is k A_Setter) => Optic k is s t a a -> a -> s -> t 22 | l -~ n = over l (subtract n) 23 | 24 | (%%~) :: (Is k A_Traversal, Applicative f) 25 | => Optic k is s t a b 26 | -> (a -> f b) 27 | -> s 28 | -> f t 29 | (%%~) = traverseOf 30 | 31 | (+=) :: (MonadState s m, Num a, Is k A_Setter) 32 | => Optic k is s s a a 33 | -> a 34 | -> m () 35 | l += b = modify (l +~ b) 36 | 37 | (-=) :: (MonadState s m, Num a, Is k A_Setter) 38 | => Optic k is s s a a 39 | -> a 40 | -> m () 41 | l -= b = modify (l -~ b) 42 | 43 | (%@~) :: (Is k A_Setter, is `HasSingleIndex` i) 44 | => Optic k is s t a b 45 | -> (i -> a -> b) 46 | -> s 47 | -> t 48 | (%@~) = iover 49 | 50 | -- using :: (Is k A_Lens, Zoom m n s t) => Optic' k is t s -> (s -> (c, s)) -> n c 51 | -- using l f = zoom l $ state f 52 | withLocal :: (PermeableOptic k a, MonadState s m, Is k A_Setter) 53 | => Optic k is s s a (ViewResult k a) 54 | -> ViewResult k a 55 | -> m b 56 | -> m b 57 | withLocal o x action = do 58 | pre' <- o <<.= x 59 | result <- action 60 | assign o pre' 61 | pure result 62 | 63 | -- It is possible to make this into a Lens, but then `failover` would not return Nothing for a non-matching small 64 | -- >>> over (refracting _1 (_tail % _init)) (first (map (*10))) ([1..5],4) 65 | -- ([1,20,30,40,5],4) 66 | -- >>> failover (refracting _1 (_tail % _init)) (first (map (*10))) ([1],4) 67 | -- Nothing 68 | refracting :: (Is k An_AffineTraversal, Is l An_AffineTraversal) 69 | => Optic' k is s a 70 | -> Optic' l js a a 71 | -> AffineTraversal' s s 72 | refracting big small 73 | = atraversal 74 | (\s -> set _Left s $ traverseOf big' (matching small) s) 75 | (\s a -> 76 | over big' (\m -> fromRight m (set small' m <$> matching big s)) a) 77 | where 78 | big' = castOptic @An_AffineTraversal big 79 | small' = castOptic @An_AffineTraversal small 80 | 81 | -- >>> insertAt 1 99 [] 82 | -- Nothing 83 | -- 84 | -- insertAt :: (Cons s s a a, Num n, Ord n) => n -> a -> s -> Maybe s 85 | -- insertAt i x = failover (_drop i) (x <|) 86 | -- 87 | -- use slicedFrom instead 88 | -- _drop :: (Num t, Cons s s a a, Ord t) => t -> AffineTraversal' s s 89 | -- _drop n 90 | -- | n <= 0 = castOptic simple 91 | -- _drop n = _tail % _drop (n - 1) 92 | is :: Is k An_AffineFold => Optic' k is s a -> s -> Bool 93 | is k = not . isn't k 94 | -- It might be possible to make this work for indexed optics too, but I haven't figured out how 95 | -- anySucceeding 96 | -- :: Is k An_AffineFold => NonEmpty (Optic' k NoIx s a) -> AffineFold s a 97 | -- anySucceeding = foldl1' afailing . fmap castOptic 98 | -- adjoinAll :: Is k A_Traversal => NonEmpty (Optic' k NoIx s a) -> Traversal' s a 99 | -- adjoinAll = foldl1' adjoin . fmap castOptic 100 | -- retraverseOf :: (Is k An_AffineTraversal, Is k A_Review, Functor f) 101 | -- => Optic' k is s a 102 | -- -> (s -> f s) 103 | -- -> a 104 | -- -> f (Either s a) 105 | -- retraverseOf p f = matching p <.> f . review p 106 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.23 2 | packages: [.] 3 | allow-newer: true 4 | extra-deps: 5 | - Interpolation-0.3.0@sha256:b0381214e6036ed2b6a0a04b7e4ec89736ca531ef03e315a3ec2c494059ff8fb,1319 6 | - base-noprelude-4.13.0.0@sha256:3cccbfda38e1422ca5cc436d58858ba51ff9114d2ed87915a6569be11e4e5a90,6842 7 | - generic-data-0.8.3.0@sha256:fef21320697370fa1fadc14f72ac3ad8092b021f5371b315be3c9f3bde44c274,3710 8 | - it-has-0.2.0.0@sha256:e0dfa84dfba835d8616b817305a80878383b8ba7ebe3c9802f33b312e7110d76,1409 9 | - jsaddle-0.9.8.1@sha256:baa0876b47cc0f0d5ca7037500daeedb9545de2f25521097bfdbf68fe58679e9,4419 10 | - jsaddle-warp-0.9.8.0@sha256:d1c75ae6ab519f923bc8a13775abd779e584bd17c96a49a76f799860bd9174e9,2713 11 | - miso-1.8.1.0@sha256:5254e49a3f695ee93f4ecc95e0e353e4a25cbcd46992f6310ac242d777a0fe55,3687 12 | - optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568 13 | - optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995 14 | - relude-1.0.0.1@sha256:35bcdaf14018e79f11e712b0e2314c1aac79976f28f4adc179985457493557d5,11569 15 | - size-based-0.1.2.0@sha256:1b33da89d270189661dbbda49a88b0c21d2fc2f7a407e7a2b1933e2faf0f5d4d,1258 16 | - testing-feat-1.1.0.0@sha256:7c7629c5014edf06aefbf30a061d1ee64c6ee15f438d868e34749fb22208ab0b,2466 17 | - servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787 18 | - optics-th-0.4 -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: Interpolation-0.3.0@sha256:b0381214e6036ed2b6a0a04b7e4ec89736ca531ef03e315a3ec2c494059ff8fb,1319 9 | pantry-tree: 10 | size: 226 11 | sha256: 1752aba83686801ae9f93c293a5555e4f694c2472a3c880ad9f05b7a05033a3c 12 | original: 13 | hackage: Interpolation-0.3.0@sha256:b0381214e6036ed2b6a0a04b7e4ec89736ca531ef03e315a3ec2c494059ff8fb,1319 14 | - completed: 15 | hackage: base-noprelude-4.13.0.0@sha256:3cccbfda38e1422ca5cc436d58858ba51ff9114d2ed87915a6569be11e4e5a90,6842 16 | pantry-tree: 17 | size: 112 18 | sha256: 90db92c8401880187ce642c5345407bcbd9546ea235524dd445cab2566ee3db1 19 | original: 20 | hackage: base-noprelude-4.13.0.0@sha256:3cccbfda38e1422ca5cc436d58858ba51ff9114d2ed87915a6569be11e4e5a90,6842 21 | - completed: 22 | hackage: generic-data-0.8.3.0@sha256:fef21320697370fa1fadc14f72ac3ad8092b021f5371b315be3c9f3bde44c274,3710 23 | pantry-tree: 24 | size: 2061 25 | sha256: bac628a423a6f86675d062f513278285b2a370f8f4a350c65a880b7043b6fb86 26 | original: 27 | hackage: generic-data-0.8.3.0@sha256:fef21320697370fa1fadc14f72ac3ad8092b021f5371b315be3c9f3bde44c274,3710 28 | - completed: 29 | hackage: it-has-0.2.0.0@sha256:e0dfa84dfba835d8616b817305a80878383b8ba7ebe3c9802f33b312e7110d76,1409 30 | pantry-tree: 31 | size: 359 32 | sha256: c99c82b9fe09f32dc03092a74e9b6765a7378652d6591a7a533b2c1bea468cc2 33 | original: 34 | hackage: it-has-0.2.0.0@sha256:e0dfa84dfba835d8616b817305a80878383b8ba7ebe3c9802f33b312e7110d76,1409 35 | - completed: 36 | hackage: jsaddle-0.9.8.1@sha256:baa0876b47cc0f0d5ca7037500daeedb9545de2f25521097bfdbf68fe58679e9,4419 37 | pantry-tree: 38 | size: 4329 39 | sha256: 0dc6ddfd83ea40b7d19d2788f0db94a9e9254ed78be47c1cef67654a5623c118 40 | original: 41 | hackage: jsaddle-0.9.8.1@sha256:baa0876b47cc0f0d5ca7037500daeedb9545de2f25521097bfdbf68fe58679e9,4419 42 | - completed: 43 | hackage: jsaddle-warp-0.9.8.0@sha256:d1c75ae6ab519f923bc8a13775abd779e584bd17c96a49a76f799860bd9174e9,2713 44 | pantry-tree: 45 | size: 475 46 | sha256: 53d9041fc7be7cdf6eec6946af1ba51d48aaaec250edff5f9a9896b53fe5d04c 47 | original: 48 | hackage: jsaddle-warp-0.9.8.0@sha256:d1c75ae6ab519f923bc8a13775abd779e584bd17c96a49a76f799860bd9174e9,2713 49 | - completed: 50 | hackage: miso-1.8.1.0@sha256:5254e49a3f695ee93f4ecc95e0e353e4a25cbcd46992f6310ac242d777a0fe55,3687 51 | pantry-tree: 52 | size: 3126 53 | sha256: 62bd8b4572c8b501b17f1cf589ca9f7536a76dba1a50db939ee06272366dce5a 54 | original: 55 | hackage: miso-1.8.1.0@sha256:5254e49a3f695ee93f4ecc95e0e353e4a25cbcd46992f6310ac242d777a0fe55,3687 56 | - completed: 57 | hackage: optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568 58 | pantry-tree: 59 | size: 1157 60 | sha256: 63595a3678ec3937ceba1eb43a44c13434610ad370705d0a8bcff723660e1508 61 | original: 62 | hackage: optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568 63 | - completed: 64 | hackage: optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995 65 | pantry-tree: 66 | size: 5315 67 | sha256: 0b8b5824efec35faede5a4c5d7c6f47c6b4708885942f7a7f73c892a5c3c5738 68 | original: 69 | hackage: optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995 70 | - completed: 71 | hackage: relude-1.0.0.1@sha256:35bcdaf14018e79f11e712b0e2314c1aac79976f28f4adc179985457493557d5,11569 72 | pantry-tree: 73 | size: 4282 74 | sha256: ead687d39d06c841de36fc214402ad4389e8837284485cfe52d975f51b274e81 75 | original: 76 | hackage: relude-1.0.0.1@sha256:35bcdaf14018e79f11e712b0e2314c1aac79976f28f4adc179985457493557d5,11569 77 | - completed: 78 | hackage: size-based-0.1.2.0@sha256:1b33da89d270189661dbbda49a88b0c21d2fc2f7a407e7a2b1933e2faf0f5d4d,1258 79 | pantry-tree: 80 | size: 480 81 | sha256: 2c8a16986903aecfc14ada381ff9f369e218feaf5dc90e934e93ecbf83905b1a 82 | original: 83 | hackage: size-based-0.1.2.0@sha256:1b33da89d270189661dbbda49a88b0c21d2fc2f7a407e7a2b1933e2faf0f5d4d,1258 84 | - completed: 85 | hackage: testing-feat-1.1.0.0@sha256:7c7629c5014edf06aefbf30a061d1ee64c6ee15f438d868e34749fb22208ab0b,2466 86 | pantry-tree: 87 | size: 790 88 | sha256: 444f3c68a4f4fa1488fbbe9e8d9bbcc5f226b12a5027ee93683d5f95bf0ece28 89 | original: 90 | hackage: testing-feat-1.1.0.0@sha256:7c7629c5014edf06aefbf30a061d1ee64c6ee15f438d868e34749fb22208ab0b,2466 91 | - completed: 92 | hackage: servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787 93 | pantry-tree: 94 | size: 392 95 | sha256: 39e0e7b2b25980bfe4df036e89959188f9ef9e8c78c85e241fa9a682d1d78cf3 96 | original: 97 | hackage: servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787 98 | - completed: 99 | hackage: optics-th-0.4@sha256:8479f64f094346d31489221ad9742324fd6c5aed0722e58fc49f0a580ceb2a18,2045 100 | pantry-tree: 101 | size: 741 102 | sha256: 26025e3641cc09e3c8abd9cdf8278710ed79ed09953c0b6047279624620c21b3 103 | original: 104 | hackage: optics-th-0.4 105 | snapshots: 106 | - completed: 107 | size: 587819 108 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/23.yaml 109 | sha256: 7f69bb29a57495586e7e3ed31ecc59c0d2c959cb23bd52b71ca676f254c9beb1 110 | original: lts-18.23 111 | -------------------------------------------------------------------------------- /test/Data/NonNegative/GenValidity.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Data.NonNegative.GenValidity where 4 | 5 | import Data.GenValidity 6 | 7 | import Test.QuickCheck 8 | 9 | instance (Ord a, Num a) => Validity (NonNegative a) where 10 | validate = declare "is non negative" . (>= NonNegative 0) 11 | 12 | instance (Num a, Ord a, Arbitrary a) => GenValid (NonNegative a) where 13 | genValid = arbitrary 14 | shrinkValid = shrink 15 | -------------------------------------------------------------------------------- /test/EvaluationSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module EvaluationSpec ( spec ) where 6 | 7 | import Data.Data 8 | import Data.GenValidity.Map () 9 | import qualified Data.Map as Map 10 | import Data.MultiSet ( MultiSet, fromOccurList ) 11 | import Data.NonNegative.GenValidity () 12 | import qualified Data.Set as Set 13 | 14 | import Frugel.Decomposition 15 | 16 | import Prelude hiding ( one ) 17 | 18 | import Scout 19 | 20 | import Test.QuickCheck 21 | import Test.Syd 22 | import Test.Syd.Validity 23 | 24 | i :: Expr 25 | i = unsafeAbstraction "x" $ unsafeVariable "x" 26 | 27 | k :: Expr 28 | k = unsafeAbstraction "x" . unsafeAbstraction "y" $ unsafeVariable "x" 29 | 30 | s :: Expr 31 | s 32 | = unsafeAbstraction "f" . unsafeAbstraction "g" . unsafeAbstraction "x" 33 | $ application' (application' (unsafeVariable "f") (unsafeVariable "x")) 34 | (application' (unsafeVariable "g") (unsafeVariable "x")) 35 | 36 | runEval' :: (Decomposable a, NodeOf a ~ Node, Unbound a, Data a) 37 | => (a -> Evaluation a) 38 | -> a 39 | -> IO (a, MultiSet EvaluationError) 40 | runEval' eval = second fst <.> runEval Nothing False Infinity eval 41 | 42 | spec :: Spec 43 | spec = describe "Evaluation" $ do 44 | simpleEvalSpec 45 | lazinessSpec 46 | shadowingSpec 47 | partialApplicationSpec 48 | expectedFunctionSpec 49 | expectedIntSpec 50 | freeVariableSpec 51 | cstrSiteSpec 52 | abstractionRenamingSpec 53 | freeVariableCaptureAvoidanceSpec 54 | freshSuffixSpec 55 | 56 | -- Simple test 57 | simpleEvalSpec :: Spec 58 | simpleEvalSpec 59 | = it "evaluates `s k k q` to `[`q`]` and reports a single FreeVariableError for `q`" 60 | $ runEval' 61 | evalExpr 62 | (application' (application' (application' s k) k) (unsafeVariable "q")) 63 | >>= shouldBe 64 | ?? ( singleExprNodeCstrSite $ unsafeVariable "q" 65 | , fromOccurList [ (FreeVariableError $ unsafeIdentifier "q", 1) ] 66 | ) 67 | 68 | -- Evaluation is lazy 69 | lazinessSpec :: Spec 70 | lazinessSpec 71 | = it "lazily evaluates `(\\u = q) ⊥ to `[`q`]` and reports a single FreeVariableError for `q`" 72 | $ runEval' evalExpr 73 | (application' (unsafeAbstraction "u" (unsafeVariable "q")) 74 | (error "should not be evaluated")) 75 | >>= shouldBe 76 | ?? ( singleExprNodeCstrSite $ unsafeVariable "q" 77 | , fromOccurList [ (FreeVariableError $ unsafeIdentifier "q", 1) ] 78 | ) 79 | 80 | -- Call-by-need 81 | -- callByNeedTest :: IO (Expr, MultiSet EvaluationError) 82 | -- callByNeedTest 83 | -- = runEval' evalExpr 84 | -- . application' 85 | -- (unsafeAbstraction "x" $ binaryOperation' (unsafeVariable "x") (unsafeVariable "x")) 86 | -- . trace "test" 87 | -- $ unsafeVariable "y" 88 | -- also tests laziness 89 | shadowingSpec :: Spec 90 | shadowingSpec 91 | = it "handles variable shadowing, e.g. `(\\x = \\x = x) q` evaluates to `\\x = x`" 92 | $ runEval' evalExpr 93 | (application' (unsafeAbstraction "x" 94 | $ unsafeAbstraction "x" 95 | $ unsafeVariable "x") 96 | (unsafeVariable "q")) 97 | >>= shouldBe 98 | ?? (unsafeAbstraction "x" $ unsafeVariable "x", fromOccurList []) 99 | 100 | partialApplicationSpec :: Spec 101 | partialApplicationSpec 102 | = it "continues evaluation in abstraction bodies when they are not fully applied in the result, e.g. `k q` evaluates to `\\y = [`q`]`" 103 | $ runEval' evalExpr (application' k $ unsafeVariable "q") >>= shouldBe 104 | ?? ( unsafeAbstraction "y" . singleExprNodeCstrSite $ unsafeVariable "q" 105 | , fromOccurList [ (FreeVariableError $ unsafeIdentifier "q", 1) ] 106 | ) 107 | 108 | expectedFunctionSpec :: Spec 109 | expectedFunctionSpec 110 | = it "reports a type error when something else than a function is found where a function is expected, e.g. in `(q + q) x`" 111 | $ runEval' 112 | evalExpr 113 | (application' 114 | (binaryOperation' (unsafeVariable "q") Plus (unsafeVariable "q")) 115 | (unsafeVariable "x")) 116 | >>= shouldBe 117 | ?? ( application' 118 | (singleExprNodeCstrSite 119 | $ binaryOperation' (singleExprNodeCstrSite $ unsafeVariable "q") 120 | Plus 121 | (singleExprNodeCstrSite $ unsafeVariable "q")) 122 | (singleExprNodeCstrSite $ unsafeVariable "x") 123 | , fromOccurList [ ( TypeError . TypeValueMismatch FunctionType 124 | $ binaryOperation' 125 | (singleExprNodeCstrSite $ unsafeVariable "q") 126 | Plus 127 | (singleExprNodeCstrSite $ unsafeVariable "q") 128 | , 1 129 | ) 130 | , (FreeVariableError $ unsafeIdentifier "q", 2) 131 | , (FreeVariableError $ unsafeIdentifier "x", 1) 132 | ] 133 | ) 134 | 135 | expectedIntSpec :: Spec 136 | expectedIntSpec 137 | = it "reports a type error when something else than an integer is found where an integer is expected, e.g. in `k + s`" 138 | $ runEval' evalExpr (binaryOperation' k Plus s) >>= shouldBe 139 | ?? ( binaryOperation' (singleExprNodeCstrSite k) 140 | Plus 141 | (singleExprNodeCstrSite s) 142 | , fromOccurList [ (TypeError $ TypeValueMismatch IntegerType k, 1) 143 | , (TypeError $ TypeValueMismatch IntegerType s, 1) 144 | ] 145 | ) 146 | 147 | freeVariableSpec :: Spec 148 | freeVariableSpec 149 | = it "reports an UnboundVariableError when it encounters a free variable, e.g. `x`" 150 | $ runEval' evalExpr (unsafeVariable "x") >>= shouldBe 151 | ?? ( singleExprNodeCstrSite $ unsafeVariable "x" 152 | , fromOccurList [ (FreeVariableError $ unsafeIdentifier "x", 1) ] 153 | ) 154 | 155 | cstrSiteSpec :: Spec 156 | cstrSiteSpec 157 | = it "continues evaluation inside construction sites" 158 | $ runEval' 159 | evalExpr 160 | (exprCstrSite' 161 | $ fromList [ Left 'c' 162 | , Right . ExprNode . application' i $ unsafeVariable "x" 163 | ]) 164 | >>= shouldBe 165 | ?? ( exprCstrSite' 166 | $ fromList 167 | [ Left 'c' 168 | , Right . ExprNode . singleExprNodeCstrSite $ unsafeVariable "x" 169 | ] 170 | , fromOccurList [ (FreeVariableError $ unsafeIdentifier "x", 1) ] 171 | ) 172 | 173 | abstractionRenamingSpec :: Spec 174 | abstractionRenamingSpec 175 | = it "renames binders to prevent them from capturing variables in expressions substituted into them" 176 | $ runEval' evalExpr (application' (churchOne "f" "x") (churchOne "f" "x")) 177 | >>= shouldBe 178 | ?? (churchOne "x" "x11", mempty) 179 | where 180 | churchOne f x 181 | = unsafeAbstraction f . unsafeAbstraction x 182 | $ application' (unsafeVariable f) (unsafeVariable x) 183 | 184 | freeVariableCaptureAvoidanceSpec :: Spec 185 | freeVariableCaptureAvoidanceSpec 186 | = it "renames binders to prevent them from capturing free variables" 187 | $ runEval' evalExpr (application' k $ unsafeVariable "y") >>= shouldBe 188 | ?? ( unsafeAbstraction "y1" . singleExprNodeCstrSite $ unsafeVariable "y" 189 | , fromOccurList [ (FreeVariableError $ unsafeIdentifier "y", 1) ] 190 | ) 191 | 192 | -- for some reason, we get a "thread blocked indefinitely in an MVar operation" when one of these tests fails 193 | freshSuffixSpec :: Spec 194 | freshSuffixSpec = modifyMaxSize (* 5) . describe "fresh variable generation" $ do 195 | it "does not rename a variable when it is not in the environment" 196 | . forAllShrink 197 | (genIdentifiers `suchThat` (null . snd . splitNumericSuffix)) 198 | shrinkValid 199 | $ \v -> let (trimmed, _) = splitNumericSuffix v 200 | in forAllShrink 201 | (genValid 202 | `suchThat` (all ((/= trimmed) . fst . splitNumericSuffix) 203 | . Map.keys)) 204 | shrinkValid 205 | $ \env -> freshSuffix v (getNonNegative <$> env) `shouldBe` 0 206 | it "adds a number larger than the number of times the variable was encountered if the variable was already in the environment" 207 | . forAllValid 208 | $ \x -> forAllShrink genIdentifiers shrinkValid $ \v -> forAllShrink 209 | (Map.insert v x <$> genValid) 210 | (filter (Map.member v) . shrinkValid) 211 | $ \env -> freshSuffix v (getNonNegative <$> env) 212 | `shouldSatisfy` (> getNonNegative x) 213 | -- maxSuccess increased to catch `freshSuffix (unsafeIdentifier "x1") $ fromList [(unsafeIdentifier "x", 1)] `shouldSatisfy` (> 0)` 214 | modifyMaxSuccess (* 100) 215 | . it "never renames to a variable already in the environment" 216 | . forAllShrink genIdentifiers shrinkValid 217 | $ \v -> forAllValid $ \env -> freshSuffix v (getNonNegative <$> env) 218 | `shouldSatisfy` (not 219 | . flip Set.member (allGeneratedIdentifiers env) 220 | . numberedIdentifier v) 221 | where 222 | -- identifiers sizes reduced to increase environment sizes 223 | genIdentifiers = genValid `resizing` (`div` 10) 224 | allGeneratedIdentifiers 225 | = Map.foldMapWithKey $ \identifier (NonNegative x) -> fromList 226 | $ map (numberedIdentifier identifier) [ 0 .. x ] 227 | 228 | resizing :: Gen a -> (Int -> Int) -> Gen a 229 | resizing gen resizer = sized $ flip resize gen . resizer 230 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | import Data.Sized 5 | 6 | import EvaluationSpec 7 | 8 | import Scout 9 | 10 | import Test.Syd 11 | import Test.Syd.Validity.GenValidity 12 | 13 | main :: IO () 14 | main = sydTest $ do 15 | describe "GenValid instance for the AST" $ do 16 | modifyMaxSize (const 100) $ genValidSpec @(Sized 100 Program) 17 | genValidSpec @ProgramMeta 18 | genValidSpec @Meta 19 | genValidSpec @CstrSite 20 | genValidSpec @Expr 21 | genValidSpec @ExprMeta 22 | genValidSpec @Identifier 23 | genValidSpec @WhereClause 24 | genValidSpec @Definition 25 | EvaluationSpec.spec 26 | -------------------------------------------------------------------------------- /weeder.dhall: -------------------------------------------------------------------------------- 1 | { roots = 2 | [ "^Main.main$" 3 | , "^Spec.main$" 4 | , "^Frugel.Action.*" 5 | , "^Control.ValidEnumerable.*" 6 | , "^Control.Limited.*" 7 | , "^Data.Constrained.*" 8 | , "^Optics.Writer.*" 9 | , "^Optics.Extra.*" 10 | , "^Scout.Node.*" 11 | , "^Optics.ReadOnly.VL.*" 12 | , "^BasicEvaluation.*" 13 | , "^Paths_.*" 14 | ] 15 | , type-class-roots = True 16 | } 17 | -------------------------------------------------------------------------------- /www/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | Frugel 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /www/style.css: -------------------------------------------------------------------------------- 1 | .no-button-style { 2 | background: none; 3 | color: inherit; 4 | border: none; 5 | padding: 0; 6 | font: inherit; 7 | cursor: auto; 8 | outline: inherit; 9 | user-select: text; 10 | text-align: left; 11 | } 12 | 13 | .code-root { 14 | margin-left: 10px; 15 | margin-right: 10px; 16 | } 17 | 18 | .code { 19 | white-space: pre; 20 | font-family: "Courier New", Courier, monospace; 21 | } 22 | 23 | .line { 24 | min-height: 1.5em; 25 | } 26 | 27 | .code-span { 28 | display: inline-block; 29 | } 30 | 31 | .elided { 32 | border: 1px solid rgb(201, 201, 201); 33 | } 34 | 35 | .code-root:focus-within .caret { 36 | width: 2px; 37 | margin: 0 -1px -0.2em -1px; 38 | height: 1.2em; 39 | animation: 1s blink step-end infinite; 40 | } 41 | 42 | @keyframes blink { 43 | from, 44 | to { 45 | background-color: transparent; 46 | } 47 | 50% { 48 | background-color: green; 49 | } 50 | } 51 | 52 | .node-padding { 53 | padding: 4px 0 4px 0; 54 | } 55 | 56 | .in-construction { 57 | background-color: hsl(48, 100%, 85%); 58 | min-width: 0.6em; 59 | } 60 | 61 | .card-header-vertical-padding { 62 | padding: 0.75rem 0; 63 | } 64 | 65 | .card-content:not(:last-child) { 66 | box-shadow: 0 0.125em 0.25em rgba(10, 10, 10, 0.1); 67 | } 68 | 69 | span { 70 | font-weight: initial; 71 | font-style: initial; 72 | } 73 | 74 | ul { 75 | margin-top: 0; 76 | } 77 | 78 | .horizontal-scroll { 79 | overflow-x: auto; 80 | } 81 | 82 | *.column { 83 | min-width: 0; 84 | } 85 | --------------------------------------------------------------------------------