├── .gitattributes ├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .hlint.yaml ├── .travis.yml ├── CHANGELOG.md ├── CODE_OF_CONDUCT.md ├── CONTRIBUTING.md ├── LICENSE.md ├── README.md ├── app ├── codex │ └── Main.hs ├── codicil │ └── Main.hs ├── layout-test │ ├── LayoutTest.hs │ └── Main.hs ├── llvm-test │ └── Main.hs └── lsp-test │ ├── ListTest.hs │ ├── Main.hs │ ├── MapTest.hs │ └── MessageTest.hs ├── bin ├── codex.sh └── travis_cabal.sh ├── cabal.project ├── coda.cabal ├── code └── extension.ts ├── data ├── coda.json └── images │ └── logo.png ├── lean ├── invertible.lean ├── mobiles.lean ├── nominal.lean ├── perm.lean └── types.lean ├── lib └── coda-console │ ├── Coda │ ├── Console.hs │ └── Console │ │ ├── Command.hs │ │ ├── Completion.hs │ │ ├── Options.hs │ │ ├── Pretty.hs │ │ ├── Settings.hs │ │ └── Unicode.hsc │ └── coda-console.cabal ├── package-lock.json ├── package.json ├── ref ├── Algebra.hs ├── Async.hs ├── Foldable.hs ├── Instances.hs ├── Measurement.hs ├── STM.hs ├── Sequence.hs ├── Sink.hs ├── View.hs ├── coda-change │ ├── Coda │ │ └── Syntax │ │ │ └── Change.hs │ └── coda-change.cabal ├── ski │ ├── Fun.hs │ ├── Implements.hs │ ├── Meta.hs │ ├── Meta2.hs │ ├── Meta3.hs │ ├── Term.hsig │ └── ski.cabal ├── stream │ └── Stream.hsig └── symantics │ ├── L.hs │ ├── P.hs │ ├── Q.hs │ ├── R.hs │ ├── RCN.hs │ ├── Symantics.hsig │ └── symantics.cabal ├── src ├── algebra │ ├── Relative │ │ └── Delta.hs │ └── Rev.hs ├── automata │ ├── Automata │ │ ├── DFA.hs │ │ ├── Internal.hs │ │ ├── NFA.hs │ │ └── Presburger.hs │ └── Set │ │ └── Lazy.hs ├── coda │ ├── Console │ │ └── Pretty │ │ │ └── LLVM.hs │ ├── LLVM.hs │ └── Syntax │ │ ├── Alex.hs │ │ ├── Error.hs │ │ ├── Lexer.x │ │ ├── Located.hs │ │ └── Name.hs ├── common │ ├── Algebra │ │ ├── Ordered.hs │ │ └── Zero.hs │ ├── FingerTree.hs │ ├── Relative │ │ └── Delta │ │ │ └── Type.hs │ ├── Syntax │ │ ├── Alex.hs │ │ ├── FromText.hs │ │ ├── Name.hs │ │ ├── Prefix.hs │ │ └── Sharing.hs │ └── Util │ │ ├── BitQueue.hs │ │ └── Bits.hs ├── console │ ├── Console.hs │ └── Console │ │ ├── Command.hs │ │ ├── Completion.hs │ │ ├── Options.hs │ │ ├── Pretty.hs │ │ └── Unicode.hsc ├── dyck │ ├── Dyck.hs │ └── Token.hsig ├── layout │ ├── Dyck.hsig │ ├── Layout.hs │ ├── Parser.hsig │ └── README.md ├── lexer │ └── Syntax │ │ └── Lexer.x ├── lsp │ └── Language │ │ └── Server │ │ ├── Builder.hs │ │ ├── Parser.hs │ │ ├── Protocol.hs │ │ └── TH.hs ├── parser │ └── Syntax │ │ └── Parser.hs ├── relative │ ├── Absolute.hs │ ├── Cat.hs │ ├── Delta.hsig │ ├── List.hs │ ├── Located.hs │ ├── Map.hs │ ├── Queue.hs │ ├── Relative.hs │ └── Semi.hs ├── rope │ ├── Document.hs │ ├── Dyck.hsig │ ├── Lexer.hsig │ ├── Rope.hs │ └── Summary.hsig ├── server │ ├── Server.hs │ └── Server │ │ └── Options.hs ├── set │ ├── Elem.hsig │ ├── Set.hs │ └── Set │ │ └── Internal.hs ├── summary-unit │ ├── Dyck.hsig │ └── Summary.hs ├── syntax │ └── Syntax.hs ├── termination │ ├── Termination.hs │ └── Termination │ │ ├── Class.hs │ │ ├── History.hs │ │ ├── Pair.hs │ │ ├── Test.hs │ │ └── Trie.hs ├── token │ └── Syntax │ │ └── Token.hs └── version │ └── Version.hs ├── test ├── code │ ├── extension.test.ts │ └── index.ts └── data │ ├── request.golden │ └── response.golden ├── tsconfig.json ├── tslint.json └── wip └── bdd ├── Data ├── BDD.hs ├── Bimap.hs └── List │ └── Skew.hs ├── Ersatz └── Solver │ └── BDD.hs ├── TODO.txt ├── bdd.cabal ├── dist └── cabal-config-flags └── examples ├── factor.hs ├── fish.hs └── sudoku ├── Main.hs └── Sudoku ├── Cell.hs └── Problem.hs /.gitattributes: -------------------------------------------------------------------------------- 1 | *.golden -text 2 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: haskell ci 2 | on: 3 | push: 4 | pull_request: 5 | workflow_dispatch: 6 | jobs: 7 | tests: 8 | runs-on: ${{ matrix.os }} 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | os: [ubuntu-latest] 13 | ghc: ['9.2.8', '9.4.5', '9.6.4', '9.8.1'] 14 | steps: 15 | - uses: actions/checkout@v4 16 | - uses: haskell-actions/setup@v2 17 | id: setup-haskell 18 | with: 19 | ghc-version: ${{ matrix.ghc }} 20 | - run: cabal build termination automata version common summary-unit set 21 | # TODO: enable these 22 | # lsp relative rope console server syntax parser layout lexer token dyck layout algebra 23 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox 2 | .coda_history 3 | .DS_Store 4 | .hsenv 5 | .stack-work 6 | .tags 7 | .vscode-test 8 | .ghc.env* 9 | *.coda 10 | *.o 11 | *.hi 12 | *.log 13 | *.swo 14 | *.swp 15 | *.vsix 16 | *~ 17 | *# 18 | cabal.project.local 19 | cabal.sandbox.config 20 | codex.tags 21 | dist 22 | dist-newstyle 23 | docs 24 | node_modules 25 | old 26 | out 27 | tags 28 | TODO.txt 29 | wiki 30 | wip 31 | ref/* 32 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: {name: "Reduce duplication"} 2 | - ignore: {name: "Use infix"} 3 | - ignore: {name: "Move brackets to avoid $"} 4 | - ignore: {name: "Use camelCase"} 5 | - ignore: {name: "Use list comprehension", within: [ Console.Pretty.LLVM ] } 6 | - ignore: {name: "Redundant bracket", within: [ Set.Lazy, Set.Internal, Console.Pretty.LLVM ] } 7 | - ignore: {name: "Eta reduce", within: [ Set.Lazy, Set.Internal, Automata.Presburger ] } 8 | - ignore: {name: "Use record patterns", within: [ Set.Lazy, Set.Internal ] } 9 | - ignore: {name: "Avoid lambda", within: [ Set.Lazy, Set.Internal ] } 10 | - ignore: {name: "Use <$>", within: [ Console.Pretty.LLVM ] } 11 | - ignore: {name: "Use String", within: [ Console.Pretty.LLVM ] } 12 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: false 3 | dist: trusty 4 | 5 | branches: 6 | except: 7 | - appveyor 8 | - circle 9 | - gh-pages 10 | 11 | git: 12 | submodules: false 13 | 14 | cache: 15 | directories: 16 | - $HOME/.cabal/packages 17 | - $HOME/.cabal/store 18 | 19 | before_cache: 20 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 21 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* 22 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json 23 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache 24 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar 25 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx 26 | 27 | matrix: 28 | include: 29 | - env: CABALVER=2.2 GHCVER=8.4.4 30 | compiler: ": #GHC 8.4.4" 31 | addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.4,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}} 32 | - env: CABALVER=2.4 GHCVER=8.6.4 33 | compiler: ": #GHC 8.6.4" 34 | addons: {apt: {packages: [cabal-install-2.4,ghc-8.6.4,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}} 35 | 36 | before_install: 37 | - . bin/travis_cabal.sh 38 | - coda_trap coda_before_install 39 | 40 | install: 41 | - coda_trap coda_install 42 | 43 | script: 44 | - coda_trap coda_script 45 | 46 | after_script: 47 | - coda_trap coda_after_script 48 | 49 | before_cache: 50 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 51 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar 52 | 53 | notifications: 54 | irc: 55 | channels: 56 | - "irc.freenode.org##coda" 57 | skip_join: true 58 | template: 59 | - "\x0313coda\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f" 60 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | Versioning 2 | ========== 3 | 4 | Note: the version of the `coda` library in Haskell is prefixed with `0.` relative to the version of the 5 | Visual Studio Code language extension. This is required to meet the [PVP](https://pvp.haskell.org/) requirements for `cabal`, and the 6 | [semantic versioning](http://semver.org/) required by Visual Studio Code, while keeping the versions in sync. 7 | 8 | The version numbers shown below are semantic version numbers. 9 | 10 | ## 0.1.0 11 | 12 | * Repository initialized. 13 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Covenant Code of Conduct 2 | 3 | ## Our Pledge 4 | 5 | In the interest of fostering an open and welcoming environment, we as contributors and maintainers pledge to making participation in our project and our community a harassment-free experience for everyone, regardless of age, body size, disability, ethnicity, gender identity and expression, level of experience, nationality, personal appearance, race, religion, or sexual identity and orientation. 6 | 7 | ## Our Standards 8 | 9 | Examples of behavior that contributes to creating a positive environment include: 10 | 11 | * Using welcoming and inclusive language 12 | * Being respectful of differing viewpoints and experiences 13 | * Gracefully accepting constructive criticism 14 | * Focusing on what is best for the community 15 | * Showing empathy towards other community members 16 | 17 | Examples of unacceptable behavior by participants include: 18 | 19 | * The use of sexualized language or imagery and unwelcome sexual attention or advances 20 | * Trolling, insulting/derogatory comments, and personal or political attacks 21 | * Public or private harassment 22 | * Publishing others' private information, such as a physical or electronic address, without explicit permission 23 | * Other conduct which could reasonably be considered inappropriate in a professional setting 24 | 25 | ## Our Responsibilities 26 | 27 | Project maintainers are responsible for clarifying the standards of acceptable behavior and are expected to take appropriate and fair corrective action in response to any instances of unacceptable behavior. 28 | 29 | Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct, or to ban temporarily or permanently any contributor for other behaviors that they deem inappropriate, threatening, offensive, or harmful. 30 | 31 | ## Scope 32 | 33 | This Code of Conduct applies both within project spaces and in public spaces when an individual is representing the project or its community. Examples of representing a project or community include using an official project e-mail address, posting via an official social media account, or acting as an appointed representative at an online or offline event. Representation of a project may be further defined and clarified by project maintainers. 34 | 35 | ## Enforcement 36 | 37 | Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by contacting the project team at ekmett@gmail.com. The project team will review and investigate all complaints, and will respond in a way that it deems appropriate to the circumstances. The project team is obligated to maintain confidentiality with regard to the reporter of an incident. Further details of specific enforcement policies may be posted separately. 38 | 39 | Project maintainers who do not follow or enforce the Code of Conduct in good faith may face temporary or permanent repercussions as determined by other members of the project's leadership. 40 | 41 | ## Attribution 42 | 43 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, available at [http://contributor-covenant.org/version/1/4][version] 44 | 45 | [homepage]: http://contributor-covenant.org 46 | [version]: http://contributor-covenant.org/version/1/4/ 47 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | Patches welcome! 2 | -------------------------------------------------------------------------------- /app/codex/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------- 3 | -- | 4 | -- Copyright : (c) Edward Kmett 2017-2018 5 | -- License : BSD-2-Clause OR Apache-2.0 6 | -- Maintainer: Edward Kmett 7 | -- Stability : experimental 8 | -- Portability: non-portable 9 | -- 10 | -------------------------------------------------------------------- 11 | 12 | module Main where 13 | 14 | import Control.Monad (join) 15 | import Data.Foldable 16 | import Options.Applicative 17 | 18 | import Console 19 | import Console.Options 20 | import Server 21 | import Server.Options 22 | import Version 23 | 24 | serverCommand, consoleCommand, commands :: Parser (IO ()) 25 | serverCommand = server <$> parseServerOptions 26 | consoleCommand = console <$> parseConsoleOptions 27 | 28 | commands = subparser $ fold 29 | [ command "repl" $ info (helper <*> consoleCommand) $ 30 | progDesc "Start a REPL" 31 | , command "server" $ info (helper <*> serverCommand) $ 32 | progDesc "Begin a language server session" 33 | , command "version" $ info (putStrLn version <$ helper) $ 34 | progDesc "Show detailed version information" 35 | ] 36 | 37 | main :: IO () 38 | main = join $ execParser $ info (helper <*> commands) $ fullDesc <> progDesc "coda" 39 | -------------------------------------------------------------------------------- /app/codicil/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | import Data.Default.Class 5 | import Data.Foldable 6 | import Options.Applicative 7 | import System.IO 8 | 9 | import Console 10 | import Console.Options 11 | import Console.Pretty 12 | import Version 13 | 14 | consoleCommand, versionCommand :: Parser (IO ()) 15 | consoleCommand = console <$> parseConsoleOptions 16 | versionCommand = pure $ putStrLn version 17 | 18 | commands :: Parser (IO ()) 19 | commands = subparser $ fold 20 | [ command "repl" $ info (helper <*> consoleCommand) $ progDesc "Start a REPL" 21 | , command "version" $ info (helper <*> versionCommand) $ progDesc "Show version information" 22 | ] 23 | 24 | main :: IO () 25 | main = do 26 | n <- fcols def stdout -- compute display columns 27 | let mods = columns n <> disambiguate 28 | join $ customExecParser (prefs mods) $ info (helper <*> commands) $ fullDesc <> progDesc "toccata" 29 | -------------------------------------------------------------------------------- /app/layout-test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF tasty-discover #-} 2 | -------------------------------------------------------------------------------- /app/llvm-test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecursiveDo #-} 3 | 4 | module Main where 5 | 6 | import LLVM.AST.Type as AST 7 | import LLVM.IRBuilder.Module 8 | import LLVM.IRBuilder.Monad 9 | import LLVM.IRBuilder.Instruction 10 | 11 | import Console.Pretty.LLVM 12 | 13 | main :: IO () 14 | main = ppll_ $ buildModule "exampleModule" $ mdo 15 | function "add" [(i32, "a"), (i32, "b")] i32 $ \[a, b] -> mdo 16 | _entry <- block `named` "entry"; do 17 | c <- add a b 18 | ret c 19 | -------------------------------------------------------------------------------- /app/lsp-test/ListTest.hs: -------------------------------------------------------------------------------- 1 | {-# language StandaloneDeriving #-} 2 | {-# language GeneralizedNewtypeDeriving #-} 3 | {-# language OverloadedLists #-} 4 | {-# language DeriveGeneric #-} 5 | {-# options_ghc -Wno-orphans #-} 6 | 7 | ----------------------------------------------------------------------------- 8 | -- | 9 | -- Copyright : (c) Edward Kmett 2017-2018 10 | -- License : BSD-2-Clause OR Apache-2.0 11 | -- Maintainer : Edward Kmett 12 | -- Stability : experimental 13 | -- Portability : non-portable 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module ListTest where 18 | 19 | import Control.Lens as Lens 20 | import Data.List as Model 21 | import GHC.Generics 22 | import Test.QuickCheck 23 | 24 | import Relative.Class 25 | import Relative.Delta 26 | import Relative.List as List 27 | 28 | deriving instance Arbitrary Delta 29 | 30 | data ListModel 31 | = Concat ListModel ListModel 32 | | Push Delta ListModel 33 | | Rel Delta ListModel 34 | | Reverse ListModel 35 | | Drop1 ListModel 36 | | NilModel 37 | deriving (Eq,Show,Generic) 38 | 39 | instance Arbitrary ListModel where 40 | arbitrary = oneof 41 | [ Concat <$> arbitrary <*> arbitrary 42 | , Push <$> arbitrary <*> arbitrary 43 | , Rel <$> arbitrary <*> arbitrary 44 | , Reverse <$> arbitrary 45 | , Drop1 <$> arbitrary 46 | , pure NilModel 47 | ] 48 | shrink = genericShrink 49 | 50 | model :: ListModel -> [Delta] 51 | model (Concat xs ys) = model xs `mappend` model ys 52 | model (Push a as) = a : model as 53 | model (Rel d as) = fmap (rel d) (model as) 54 | model (Reverse as) = Model.reverse (model as) 55 | model NilModel = [] 56 | model (Drop1 as) = Model.drop 1 (model as) 57 | 58 | eval :: ListModel -> List Delta 59 | eval (Concat xs ys) = eval xs `mappend` eval ys 60 | eval (Push a as) = cons a (eval as) 61 | eval (Rel d as) = rel d (eval as) 62 | eval (Reverse as) = List.reverse (eval as) 63 | eval NilModel = [] 64 | eval (Drop1 as) = case Lens.uncons (eval as) of 65 | Just (_, as') -> as' 66 | Nothing -> [] 67 | 68 | prop_list :: ListModel -> Property 69 | prop_list x = unfoldr Lens.uncons (eval x) === model x 70 | -------------------------------------------------------------------------------- /app/lsp-test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF tasty-discover #-} 2 | -------------------------------------------------------------------------------- /app/lsp-test/MapTest.hs: -------------------------------------------------------------------------------- 1 | {-# language StandaloneDeriving #-} 2 | {-# language GeneralizedNewtypeDeriving #-} 3 | {-# language DeriveGeneric #-} 4 | {-# options_ghc -Wno-orphans #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Copyright : (C) Edward Kmett 2017-2018 9 | -- License : BSD-2-Clause OR Apache-2.0 10 | -- Maintainer : Edward Kmett 11 | -- Stability : experimental 12 | -- Portability : non-portable 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module MapTest where 17 | 18 | import Data.Map.Strict as Model 19 | import GHC.Generics 20 | import Test.QuickCheck 21 | 22 | import Relative.Class 23 | import Relative.Delta 24 | import Relative.Map as Relative 25 | 26 | deriving instance Arbitrary Delta 27 | 28 | type Key = Delta 29 | type Value = Delta 30 | 31 | data Model 32 | = Union Model Model 33 | | Insert Key Value Model 34 | | Rel Delta Model 35 | -- | Delete Key Model 36 | | Empty 37 | deriving (Eq,Show,Generic) 38 | 39 | instance Arbitrary Model where 40 | arbitrary = oneof 41 | [ 42 | -- Union <$> arbitrary <*> arbitrary 43 | Insert <$> arbitrary <*> arbitrary <*> arbitrary 44 | , Rel <$> arbitrary <*> arbitrary 45 | , pure Empty 46 | ] 47 | shrink = genericShrink 48 | 49 | model :: Model -> Model.Map Key Value 50 | model (Union xs ys) = model xs `mappend` model ys 51 | model (Insert k v as) = Model.insert k v $ model as 52 | model (Rel d as) = Model.fromList $ fmap (birel d) $ Model.toList $ model as 53 | model Empty = mempty 54 | 55 | eval :: Model -> Relative.Map Key Value 56 | eval (Union xs ys) = eval xs `mappend` eval ys 57 | eval (Insert k v as) = Relative.insert k v $ eval as 58 | eval (Rel d as) = rel d $ eval as 59 | eval Empty = mempty 60 | 61 | prop_map :: Model -> Property 62 | prop_map x = counterexample (show ex) $ Relative.toAscList ex === Model.toAscList (model x) where 63 | ex = eval x 64 | 65 | prop_map_1 :: Property 66 | prop_map_1 = prop_map $ Insert 1 2 (Rel 4 (Insert 8 16 Empty)) 67 | 68 | prop_map_2 :: Property 69 | prop_map_2 = prop_map $ Insert 1 4 (Rel 1 (Insert 0 1 Empty)) 70 | 71 | -- [(1,1),(2,1)] /= [(1,0),(2,1)] -- insert is not clobbering in relative map 72 | prop_map_3 :: Property 73 | prop_map_3 = prop_map $ Insert 1 0 (Rel 1 (Insert 1 0 (Insert 0 0 Empty))) 74 | 75 | prop_map_3' :: Property 76 | prop_map_3' = prop_map $ Rel 1 (Insert 1 0 (Insert 0 0 Empty)) 77 | 78 | prop_map_3'' :: Property 79 | prop_map_3'' = prop_map $ Insert 1 0 (Insert 0 0 Empty) 80 | 81 | prop_map_4 :: Property 82 | prop_map_4 = prop_map $ Union (Insert 0 0 (Insert 1 0 Empty)) (Rel 1 (Insert 1 0 (Insert 0 0 Empty))) 83 | -------------------------------------------------------------------------------- /app/lsp-test/MessageTest.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | {-# language OverloadedStrings #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Copyright : (c) Edward Kmett 2017-2018 7 | -- License : BSD-2-Clause OR Apache-2.0 8 | -- Maintainer : Edward Kmett 9 | -- Stability : experimental 10 | -- Portability : non-portable 11 | -- 12 | ----------------------------------------------------------------------------- 13 | 14 | module MessageTest 15 | ( test_message 16 | ) where 17 | 18 | import Control.Lens ((<&>)) 19 | import Data.Aeson (ToJSON, FromJSON, Value(..), fromJSON, toJSON, Result(..)) 20 | import Data.ByteString.Builder 21 | import Data.Tagged 22 | import System.FilePath 23 | import System.IO 24 | import Test.Tasty 25 | import Test.Tasty.Golden 26 | import Test.Tasty.HUnit 27 | import Test.Tasty.Providers as Tasty 28 | 29 | import Paths_coda (getDataDir) 30 | import Language.Server.Parser 31 | import Language.Server.Builder 32 | import Language.Server.Protocol 33 | 34 | 35 | goldenFile :: TestName -> FilePath 36 | goldenFile name = "test" "data" name <.> "golden" 37 | 38 | newtype ParseTest = ParseTest (IO Tasty.Result) 39 | instance IsTest ParseTest where 40 | run _ (ParseTest r) _ = r 41 | testOptions = Tagged [] 42 | 43 | -- | perform a golden file test and round-trip test 44 | golden :: (ToJSON a, FromJSON a, Show a, Eq a) => TestName -> a -> TestTree 45 | golden name content 46 | = testGroup name 47 | [ goldenVsString "encoding" (goldenFile name) $ 48 | pure $ toLazyByteString $ buildMessage content 49 | , singleTest "parser" $ ParseTest $ do 50 | dd <- getDataDir 51 | withFile (dd goldenFile name) ReadMode $ \handle -> 52 | parse eitherDecodeMessage' handle >>= \case 53 | Left e -> pure $ testFailed $ "bad JSON-RPC frame: " ++ e 54 | Right (Left e) -> pure $ testFailed $ "bad JSON message: " ++ e 55 | Right (Right content') 56 | | content' /= content -> pure $ testFailed "content mismatch" 57 | | otherwise -> hIsEOF handle <&> \fin -> if fin 58 | then testPassed "" 59 | else testFailed "leftover content" 60 | , testCase "value" $ fromJSON (toJSON content) @=? Success content 61 | ] 62 | 63 | test_message :: TestTree 64 | test_message = testGroup "message" 65 | [ golden "request" $ Request (Just (IntId 1)) "request" Nothing 66 | , golden "response" $ Response (Just "id") (Just (Number 2)) Nothing 67 | ] 68 | -------------------------------------------------------------------------------- /bin/codex.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | EXE=codex 3 | cabal new-build exe:$EXE -v0 -- $* 1>&2 4 | ABSEXE=`cabal new-exec which $EXE` 5 | if [ ! -x "$ABSEXE" ]; then 6 | sleep 5 7 | echo "Content-Length: 87\r\n\r" 8 | echo '{"jsonrpc":"2.0","id":1,"error":{"code":-32099,"message":"Cannot build codex"}}' 9 | exit 1 10 | fi 11 | 12 | exec $ABSEXE $@ 13 | -------------------------------------------------------------------------------- /bin/travis_cabal.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | shell_session_update() { 4 | echo "invoked shell_session_update" 5 | } 6 | 7 | coda_before_install() { 8 | set -x 9 | unset CC 10 | export HAPPYVER=1.19.5 11 | export ALEXVER=3.1.7 12 | export CABALFLAGS="$CABALFLAGS -v2" 13 | export PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:~/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH 14 | set +x 15 | } 16 | 17 | coda_install() { 18 | set -x 19 | cabal --version 20 | cabal update 21 | set +x 22 | } 23 | 24 | coda_script() { 25 | set -x 26 | time cabal new-build all 27 | time cabal new-test all 28 | # npm install 29 | # vsce package 30 | # unzip -v *.vsix 31 | set +x 32 | } 33 | 34 | coda_after_script() { 35 | set -x 36 | # cabal install hpc-coveralls 37 | # hpc-coveralls coda-doctests coda-spec --exclude-dir=test --display-report 38 | set +x 39 | } 40 | 41 | coda_trap() { 42 | set -e 43 | $* 44 | set +e 45 | } 46 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | allow-newer: llvm-hs-pure:transformers 4 | -------------------------------------------------------------------------------- /code/extension.ts: -------------------------------------------------------------------------------- 1 | 'use strict'; 2 | import * as path from 'path'; 3 | import { workspace, Disposable, ExtensionContext } from 'vscode'; 4 | import { LanguageClient, LanguageClientOptions, SettingMonitor, ServerOptions } from 'vscode-languageclient'; 5 | export function activate(context: ExtensionContext) { 6 | let serverPath = context.asAbsolutePath(path.join('bin', process.platform === 'win32' ? 'codex.bat' : 'codex.sh')); 7 | let serverOptions: ServerOptions = { 8 | run : { command: serverPath, args: ['server'] }, 9 | debug: { command: serverPath, args: ['server', '--debug'] } 10 | }; 11 | let clientOptions: LanguageClientOptions = { 12 | documentSelector: ['coda'], 13 | synchronize: { 14 | configurationSection: 'coda', 15 | fileEvents: workspace.createFileSystemWatcher('**/.codarc') 16 | } 17 | }; 18 | let disposable = new LanguageClient('coda', 'Coda Language Server', serverOptions, clientOptions).start(); 19 | context.subscriptions.push(disposable); 20 | } 21 | -------------------------------------------------------------------------------- /data/coda.json: -------------------------------------------------------------------------------- 1 | { 2 | "comments": { 3 | "lineComment": "--" 4 | }, 5 | "brackets": [ 6 | ["{", "}"], 7 | ["[", "]"], 8 | ["(", ")"] 9 | ], 10 | "autoClosingPairs": [ 11 | ["{", "}"], 12 | ["[", "]"], 13 | ["(", ")"], 14 | ["\"", "\""], 15 | ["'", "'"] 16 | ], 17 | "surroundingPairs": [ 18 | ["{", "}"], 19 | ["[", "]"], 20 | ["(", ")"], 21 | ["\"", "\""], 22 | ["'", "'"] 23 | ] 24 | } 25 | -------------------------------------------------------------------------------- /data/images/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ekmett/coda/ed9d720737bf6f1d025d6a587c9435e71fd4f8ec/data/images/logo.png -------------------------------------------------------------------------------- /lean/invertible.lean: -------------------------------------------------------------------------------- 1 | open function 2 | open sigma 3 | 4 | section bijections 5 | universes u₁ u₂ 6 | variables {α : Type u₁} {β : Type u₂} 7 | 8 | -- promote some existing propositions to classes 9 | attribute [class] injective 10 | attribute [class] surjective 11 | attribute [class] bijective 12 | attribute [class] has_left_inverse 13 | attribute [class] has_right_inverse 14 | 15 | instance mk_bijective {f: α → β} [fi : injective f] [fs: surjective f]: bijective f 16 | := (| fi, fs |) 17 | 18 | instance bijective_injective {f: α → β} [bf: bijective f]: injective f := bf.1 19 | instance bijective_surjective {f: α → β} [bf: bijective f]: surjective f := bf.2 20 | 21 | instance has_left_inverse_injective {f : α → β} [h : has_left_inverse f]: injective f := 22 | injective_of_has_left_inverse h 23 | 24 | instance has_right_inverse_surjective {f : α → β} [h : has_right_inverse f]: surjective f := 25 | surjective_of_has_right_inverse h 26 | end bijections 27 | 28 | structure {u₁ u₂} invertible {α : Type u₁} {β : Type u₂} (f : α → β) := 29 | (invf : β → α) 30 | (invinj : injective invf) 31 | (linv : left_inverse invf f) 32 | attribute [class] invertible 33 | 34 | section inverses 35 | -- computable inverses 36 | 37 | -- end goal: uniqueness of inverses 38 | universes u₁ u₂ 39 | variables {α : Type u₁} {β : Type u₂} 40 | 41 | def inverse (f : α → β) [iF : invertible f]: β → α := invertible.invf iF 42 | 43 | def invertible_left_inverse (f : α → β) [iF : invertible f]: left_inverse (inverse f) f := 44 | invertible.linv iF 45 | 46 | def invertible_right_inverse (f : α → β) [iF : invertible f]: right_inverse (inverse f) f := 47 | right_inverse_of_injective_of_left_inverse (invertible.invinj iF) (invertible.linv iF) 48 | 49 | def invertible_has_right_inverse (f : α → β) [iF : invertible f]: has_right_inverse f := 50 | exists.intro (invertible.invf iF) (invertible_right_inverse f) 51 | 52 | def invertible_has_left_inverse (f : α → β) [iF : invertible f]: has_left_inverse f := 53 | exists.intro (invertible.invf iF) (invertible.linv iF) 54 | 55 | instance invertible_injective_inverse {f : α → β} [iF : invertible f]: injective (inverse f) := 56 | invertible.invinj iF 57 | 58 | instance invertible_surjective {f : α → β} [iF : invertible f]: surjective f := 59 | begin 60 | destruct (invertible_has_right_inverse f), 61 | intros g fg b, 62 | apply exists.intro, 63 | exact (fg b) 64 | end 65 | 66 | instance invertible_injective {f: α → β} [iF : invertible f]: injective f := 67 | injective_of_has_left_inverse (invertible_has_left_inverse f) 68 | 69 | instance invertible_surjective_inverse {f : α → β} [iF : invertible f]: surjective (inverse f) := 70 | begin 71 | intro a, 72 | apply exists.intro, 73 | exact (invertible.linv iF a), 74 | end 75 | 76 | instance invertible_inverse {f : α → β} [iF : invertible f]: invertible (inverse f) := 77 | invertible.mk f invertible_injective (invertible_right_inverse f) 78 | 79 | instance invertible_bijective (f : α → β) [iF : invertible f]: bijective f := 80 | (| invertible_injective, invertible_surjective |) 81 | 82 | instance invertible_bijective_inverse (f : α → β) [iF : invertible f]: bijective (inverse f) := 83 | (| invertible_injective_inverse, invertible_surjective_inverse |) 84 | 85 | -- def invertible_is_unique {f : α → β} (p q: invertible f) : p = q -- up to funext/propext 86 | 87 | end inverses 88 | 89 | def {u1 u2 u3} lhs {α : Sort u1} { β : Sort u2 } {γ : Sort u3} (f g : β → α) (h : γ -> β) (fg : f = g) : f ∘ h = g ∘ h := 90 | eq.subst fg (@eq.refl (γ → α) (f ∘ h)) 91 | 92 | def {u1 u2 u3} rhs {α : Sort u1} { β : Sort u2 } {γ : Sort u3} (f : β → α) (g h : γ -> β) (gh : g = h) : f ∘ g = f ∘ h := 93 | eq.subst gh (@eq.refl (γ → α) (f ∘ g)) 94 | 95 | -------------------------------------------------------------------------------- /lean/mobiles.lean: -------------------------------------------------------------------------------- 1 | import .invertible 2 | open function 3 | 4 | -- mostly just experimenting with more complicated symmetries, etc. 5 | section mobiles 6 | 7 | inductive rose : Type 8 | | leaf : rose 9 | | node : (ℕ -> rose) -> rose 10 | 11 | -- mobile equivalence 12 | inductive mobile : rose -> rose -> Prop 13 | | leaf : mobile rose.leaf rose.leaf 14 | | node : Π {f g : ℕ -> rose}, (∀ {n : ℕ}, mobile (f n) (g n)) → mobile (rose.node f) (rose.node g) 15 | | perm : Π (g : ℕ -> rose) (f : ℕ -> ℕ) [bf : invertible f], mobile (rose.node g) (rose.node (g∘f)) 16 | 17 | @[refl] def mobile_refl : ∀ p : rose, mobile p p := 18 | @rose.rec (λ x, mobile x x) mobile.leaf (λ _, mobile.node) 19 | 20 | @[symm] def mobile_symm : ∀ p q : rose, mobile p q -> mobile q p := 21 | begin 22 | apply (@mobile.rec (λ x y, mobile y x) mobile.leaf), 23 | intros f0 g0 _x h, 24 | apply mobile.node, 25 | intros n, 26 | apply h, 27 | intros g f bf, 28 | let f' := invertible.invf bf, 29 | let ri := @invertible_right_inverse ℕ ℕ f bf, 30 | let go := rhs g (f ∘ f') id (id_of_left_inverse ri), 31 | let reg := eq.trans (eq.trans (comp.assoc g f f') go) (comp.right_id g), 32 | apply (eq.subst reg), 33 | let gfg := eq.symm (lhs ((g ∘ f) ∘ f') g f reg), 34 | refine (eq.subst gfg _), 35 | exact (@mobile.perm (g ∘ f) f' (@invertible_inverse ℕ ℕ f bf)) 36 | end 37 | 38 | 39 | --@[trans] def mobile_trans : ∀ p q r : rose, mobile p q → mobile q r -> mobile p r := 40 | -- begin admit 41 | -- end 42 | 43 | end mobiles 44 | 45 | 46 | -------------------------------------------------------------------------------- /lean/nominal.lean: -------------------------------------------------------------------------------- 1 | open function 2 | open group 3 | 4 | -- generally following 5 | -- https://www.cl.cam.ac.uk/~amp12/agda/choudhury/choudhury-dissertation.pdf 6 | 7 | def atom : Type := ℕ 8 | 9 | def {u} neq {A : Sort u} (a b : A) : Prop 10 | := (a = b) → false 11 | 12 | inductive nelem (a : ℕ) : list ℕ → Prop 13 | | nil : nelem [] 14 | | cons : Π {b as}, nelem as -> neq a b -> nelem (b :: as) 15 | 16 | inductive all {A : Type} (P : A → Prop): list A → Prop 17 | | nil : all [] 18 | | cons : ∀ {a as}, P a → all as → all (a :: as) 19 | 20 | -- all is a functor from (i -> Prop) to [i] -> Prop 21 | def all.map {A : Type} {P Q : A -> Prop} (pq : ∀ {a : A}, P a → Q a) {as : list A} 22 | : all P as → all Q as 23 | := @all.rec _ P (all Q) (all.nil Q) (λ {a as} p _ qs, all.cons (pq p) qs) as 24 | 25 | @[pattern] def Z : ℕ := nat.zero 26 | @[pattern] def S : ℕ -> ℕ := nat.succ 27 | 28 | variables a b c: ℕ 29 | 30 | @[simp] 31 | def greater: ℕ := S (max a b) 32 | 33 | @[simp] 34 | def nat_one_add : 1 + a = S a := eq.trans (nat.add_comm 1 a) (nat.add_one a) 35 | 36 | def max_succ : max (S a) (S b) = S (max a b) := begin 37 | refine (eq.subst (nat_one_add a) _), 38 | refine (eq.subst (nat_one_add b) _), 39 | refine (eq.subst (nat_one_add (max a b)) _), 40 | exact (max_add_add_left 1 a b) 41 | end 42 | 43 | def greater_succ : greater (S a) (S b) = S (greater a b) := begin 44 | let m : max (S a) (S b) = greater a b := max_succ a b, 45 | refine (eq.subst m _), 46 | reflexivity, 47 | end 48 | 49 | def greater0 : greater 0 a = S a := begin 50 | let m0a : max 0 a = a := max_eq_right (eq.subst (nat.zero_add a) (nat.le_add_right 0 a)), 51 | let Sm0a : S (max 0 a) = S a := by cc, 52 | exact Sm0a 53 | end 54 | 55 | def greater.comm : greater a b = greater b a := begin 56 | let m := max_comm a b, 57 | let sm : S (max a b) = S (max b a) := by cc, 58 | exact sm 59 | end 60 | 61 | variable as : list ℕ 62 | 63 | def all_lt (b : ℕ) := all (λ a, a < b) as 64 | 65 | notation as `≺`:50 b := @all_lt as b 66 | 67 | def all_lt_le (asb : as ≺ b) (bc : b <= c): as ≺ c 68 | := all.map (λ {a} ab, lt_of_lt_of_le ab bc) asb 69 | 70 | def all_lt_lt (asb : as ≺ b) (bc : b < c): as ≺ c 71 | := all.map (λ {a} ab, trans ab bc) asb 72 | 73 | def lt_greater_left (b c : ℕ): b < greater b c := nat.lt_succ_of_le (le_max_left b c) 74 | def lt_greater_right (b c : ℕ): c < greater b c := nat.lt_succ_of_le (le_max_right b c) 75 | 76 | def outside : list ℕ -> ℕ := list.foldr greater 0 77 | 78 | def outside_more : outside as <= outside (a :: as) := begin 79 | let m : greater a (outside as) = outside (a :: as) , refl, 80 | refine (trans _ (le_of_eq m)), 81 | refine (le_of_lt _), 82 | exact (lt_greater_right a (outside as)) 83 | end 84 | 85 | def outside_lt : as ≺ outside as := begin 86 | introv, 87 | induction as, 88 | refine (all.nil _), -- nil 89 | refine (all.cons _ (all.map _ as_ih)), -- cons 90 | calc as_hd < greater as_hd (outside as_tl) : lt_greater_left as_hd (outside as_tl) 91 | ... = outside (as_hd :: as_tl) : by refl, 92 | intros a ao, 93 | exact (lt_of_lt_of_le ao (outside_more as_hd as_tl)) 94 | end 95 | 96 | -- permutations 97 | structure perm := (perm: list (ℕ × ℕ)) 98 | 99 | def swap : ℕ × ℕ → ℕ → ℕ 100 | | ⟨a, b⟩ c := if a = c then b else if b = c then a else c 101 | 102 | def act (p:perm) (n:ℕ) : ℕ := list.foldr swap n p.1 103 | 104 | def injective_act (p:perm): injective (act p) := 105 | by admit 106 | 107 | def surjective_act (p:perm): surjective (act p) := 108 | by admit 109 | 110 | -- bijective (act p) 111 | -- has_left_inverse (act p) 112 | -- has_right_inverse (act p) 113 | -- invertible (act p) 114 | 115 | -- TODO: prove that act is a group homomorphism 116 | 117 | instance perm_inv : has_inv perm := by 118 | apply has_inv.mk; intro a; cases a; exact (perm.mk (list.reverse a)) 119 | 120 | def reverse.injective {A : Type}: injective (@list.reverse A) := 121 | by admit 122 | 123 | def reverse.surjective {A: Type}: surjective (@list.reverse A) := 124 | by admit 125 | 126 | -- messy, requires actual equality! quotient by permutation equivalence? 127 | -- or i can just make my own setoid encoding, blah 128 | instance group_perm : group perm 129 | := begin 130 | apply group.mk, 131 | admit, -- inverse proof 132 | intros p q; cases p; cases q; exact (perm.mk (p ++ q)), -- cleanup? 133 | admit, -- associativity of append 134 | exact (perm.mk []), 135 | begin intro, admit, end, -- 1*a = a 136 | admit, -- a *1 = a 137 | exact perm_inv.1, 138 | end -------------------------------------------------------------------------------- /lean/perm.lean: -------------------------------------------------------------------------------- 1 | open function 2 | open nat 3 | 4 | 5 | -- seeking some position i, currently at some position n. 6 | -- todo: convert a cursor to a Prop 7 | def cursor (n s i k: ℕ) := n + s * k = i ∧ s > 0 8 | 9 | -- k = 0 → i = n 10 | 11 | def start(i: ℕ) : cursor 0 1 i i := begin 12 | -- apply (@cursor.mk 0 1 i i), 13 | apply and.intro, 14 | rw [zero_add, one_mul], 15 | from nat.zero_lt_one_add 0, 16 | end 17 | 18 | inductive action :Π (n s i k: ℕ), cursor n s i k → Type 19 | | stop: Π (n s i: ℕ) (c : cursor n s i 0), action n s i 0 c 20 | | left: Π (n s i k: ℕ) (c : cursor n s i k), (k - 1) % 2 = 0 → cursor (n + s) (s*2) i ((k-1)/2) → action n s i k c 21 | | right: Π (n s i k: ℕ) (c : cursor n s i k), (k - 1) % 2 = 1 → cursor (n + 2 * s) (s*2) i ((k-1)/2) → action n s i k c 22 | 23 | private def lt_not_gt (m n: ℕ) (mn : m < n): ¬ m ≥ n := ((@nat.lt_iff_le_not_le m n).1 mn).2 24 | 25 | def step: Π(n s i k : ℕ) (c : cursor n s i k), action n s i k c := begin 26 | introv, cases h : c with pi ps, cases k with km1, 27 | refine (action.stop n s i _), -- k = 0, stop 28 | have ds : s * 2 > 0, by rw [← nat.zero_mul 2]; from mul_lt_mul_of_pos_right ps (nat.zero_lt_one_add 1), 29 | have range: km1%2 < 2 := @nat.mod_lt km1 2 (nat.zero_lt_one_add 1), 30 | have sp : succ km1 - 1 = km1 := by simp, 31 | by_cases h2 : km1 % 2 <= 0, 32 | begin -- (k-1) % 2 = 0, go left 33 | apply action.left n s i (succ km1), from nat.eq_zero_of_le_zero h2, -- apply @cursor.mk (n+s) (s*2) i (km1/2) 34 | refine (and.intro _ ds), 35 | begin -- proof 36 | rw [sp, ← pi, nat.mul_assoc _ 2,← nat.zero_add (2*_), ← eq_zero_of_le_zero h2, mod_add_div], 37 | refine (eq.symm _), rw [← one_add km1, left_distrib, mul_one, ← add_assoc], 38 | end 39 | end, 40 | begin -- (k-1) % 2 = 1, go right 41 | have r_equals_1 : km1%2 = 1, 42 | begin 43 | cases h2 : km1 % 2, let c := nat.le_of_eq h2, contradiction, -- not 0 44 | cases n_1, refl, -- exactly 1 45 | exfalso, refine (lt_not_gt (km1%2) 2 range _), erw [h2], from succ_le_succ (succ_le_succ (zero_le n_1)) -- not 2+ 46 | end, 47 | apply action.right n s i, from r_equals_1, -- apply @cursor.mk (n+2*s) (s*2) i (km1/2) 48 | refine and.intro _ ds, 49 | begin -- proof 50 | rw [sp, mul_assoc, mul_comm _ s, add_assoc, ← left_distrib], 51 | have p11 : 2 + 2 * (km1 / 2) = 1 + 1 + 2 * (km1 / 2), by refl, 52 | have p1r : 1 + 1 = 1 + km1%2, by rw [r_equals_1], 53 | rw [p11, p1r, add_assoc, mod_add_div, add_comm 1 km1], 54 | from pi, 55 | end 56 | end 57 | end 58 | 59 | inductive T: Π(n s : ℕ) (occ : Prop), Type 60 | | tip : Π(n s: ℕ), T n s false 61 | | bin : Π (n s j: ℕ) (x y : Prop), n ≠ j ∨ x ∨ y → T (n+s) (2*s) x → T (n+2*s) (2*s) y → T n s true 62 | 63 | 64 | -- better to work with 'steps' that go from some position to another position, and thread a list of them 65 | 66 | inductive path: (n s i k: ℕ): cursor n s i k → Type 67 | | step: action n s i k -> 68 | 69 | 70 | structure tree := (occ : Prop) (content: T 0 1 occ) 71 | 72 | -- def well_founded.fix_F : Π {α : Sort u} {r : α → α → Prop} {C : α → Sort v}, 73 | -- (Π (x : α), (Π (y : α), r y x → C y) → C x) → Π (x : α), acc r x → C x 74 | -- nat.well_founded 75 | 76 | -- C is my path down to a state with 'k' remainining 77 | 78 | -- def step1 : (Π (x : ℕ), (Π (y : ℕ), y < x → C y) → C x) 79 | -- def wat := well_founded.fix lt_wf step1 -- should i use a sub-relation of lt_wf? 80 | 81 | 82 | -- induction on k 83 | def set.rec: Π (n s i j k: ℕ) (c: cursor n s i k) (o: Prop) (t : T n s o), Σ p : Prop, T n s p := begin 84 | simp_intros n s i j k c o t, 85 | let act := step n s i k c, 86 | cases hact: act, 87 | begin 88 | have ni : n = i := c_1.1, 89 | cases ht: t, by_cases ij: i = j, 90 | -- i = j, stop, tip 91 | from sigma.mk false (T.tip n s), 92 | -- i /= j, stop, tip 93 | apply sigma.mk true, apply (T.bin n s j false false), 94 | rw [ni]; from or.inl ij, 95 | apply T.tip, apply T.tip, 96 | by_cases ij: i = j, 97 | -- i = j, stop, bin 98 | cases ha_1: a_1, cases ha_2: a_2, 99 | apply sigma.mk false, apply T.tip, 100 | repeat { apply sigma.mk true, apply T.bin _ _ j _ _ _ a_1 a_2, simp }, 101 | rw [ni], from or.inl ij 102 | end, 103 | begin 104 | apply set.rec, 105 | end, 106 | begin admit 107 | end, 108 | end 109 | 110 | -- def set (i j: ℕ) (t0: tree): tree := 111 | 112 | -- #reduce step 0 11 (start 11) 113 | 114 | -- simple implicit-heap-like navigation 115 | namespace dir 116 | @[simp] def u (i:ℕ) := (i-1)/2 117 | @[simp] def l (i:ℕ) := i*2+1 118 | @[simp] def r (i:ℕ) := i*2+2 119 | 120 | def ul : left_inverse u l := begin 121 | delta u l left_inverse at ⊢, simp_intros i, 122 | rw [add_comm, nat.add_sub_cancel, nat.mul_div_cancel i (nat.zero_lt_one_add 1)], 123 | end 124 | 125 | def ur : left_inverse u r := begin 126 | delta u r left_inverse at ⊢, simp_intros i, 127 | erw [add_comm, nat.add_sub_cancel (i*2+1) 1, add_comm, mul_comm, nat.add_mul_div_left 1 i (nat.zero_lt_one_add 1), zero_add], 128 | end 129 | end dir 130 | -------------------------------------------------------------------------------- /lean/types.lean: -------------------------------------------------------------------------------- 1 | inductive ty : Type 2 | | i : ty 3 | | arr : ty -> ty -> ty 4 | 5 | inductive ctx : Type 6 | | n : ctx 7 | | s : ctx -> ty -> ctx 8 | 9 | notation Γ >> σ := ctx.s Γ σ 10 | 11 | inductive var : ctx -> ty -> Type 12 | | z : ∀ (Γ : ctx) (σ : ty), var (Γ >> σ) σ 13 | | s : ∀ (Γ : ctx) (σ : ty), var Γ σ → var (Γ >> σ) σ 14 | 15 | inductive tm : ctx -> ty -> Type 16 | | vr : ∀ (Γ : ctx) (σ : ty), var Γ σ → tm Γ σ 17 | | ap : ∀ (Γ : ctx) (σ τ : ty), tm Γ (ty.arr σ τ) -> tm Γ σ -> tm Γ τ 18 | | lm : ∀ (Γ : ctx) (σ τ : ty), tm (Γ >> σ) τ -> tm Γ (ty.arr σ τ) 19 | -------------------------------------------------------------------------------- /lib/coda-console/Coda/Console.hs: -------------------------------------------------------------------------------- 1 | {-# language OverloadedStrings #-} 2 | -------------------------------------------------------------------- 3 | -- | 4 | -- Copyright : (c) Edward Kmett 2017, (c) Edward Kmett and Dan Doel 2012-2014 5 | -- License : BSD2 6 | -- Maintainer: Edward Kmett 7 | -- Stability : experimental 8 | -- Portability: non-portable 9 | -- 10 | -- Start a REPL 11 | -------------------------------------------------------------------- 12 | 13 | module Coda.Console 14 | ( heading 15 | , console 16 | ) where 17 | 18 | import Coda.Syntax.Dyck 19 | import Coda.Syntax.Lexer 20 | import Data.String 21 | import Coda.Console.Command 22 | import Coda.Console.Completion 23 | import Coda.Console.Options 24 | import Coda.Console.Unicode 25 | import Coda.Version 26 | import Control.Exception.Lens 27 | import Control.Lens 28 | import Control.Monad.State 29 | import Data.Char 30 | import Data.Text (pack) 31 | import System.Console.Haskeline 32 | import System.Exit.Lens 33 | import Prelude hiding (lex) 34 | 35 | heading :: String 36 | heading = "Coda, version " ++ version ++ ": http://github.com/ekmett/coda/ :? for help" 37 | 38 | console :: ConsoleOptions -> IO () 39 | console opts = withUnicode $ do 40 | unless (opts^.consoleOptionsNoHeading) $ putStrLn heading 41 | runInputT settings loop 42 | 43 | loop :: InputT IO () 44 | loop = do 45 | minput <- getInputLine "λ> " 46 | case Prelude.dropWhile isSpace <$> minput of 47 | Nothing -> return () 48 | Just "quit" -> return () 49 | Just (':':cmd) -> do 50 | lift $ handling (filtered (hasn't _ExitCode)) (liftIO . print) $ executeCommand cmd 51 | loop 52 | Just "" -> loop 53 | Just input -> do 54 | outputStrLn $ show $ spine (lex (pack input)) 55 | loop 56 | -------------------------------------------------------------------------------- /lib/coda-console/Coda/Console/Command.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ExtendedDefaultRules #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 10 | 11 | -------------------------------------------------------------------- 12 | -- | 13 | -- Copyright : (c) Edward Kmett 2017, (c) Edward Kmett and Dan Doel 2012-2013 14 | -- License : BSD2 15 | -- Maintainer: Edward Kmett 16 | -- Stability : experimental 17 | -- Portability: non-portable 18 | -- 19 | -------------------------------------------------------------------- 20 | 21 | module Coda.Console.Command 22 | ( Command(..) 23 | , HasCommand(..) 24 | , commands 25 | , executeCommand 26 | ) where 27 | 28 | import Coda.Console.Pretty 29 | import Coda.Version 30 | import Coda.Syntax.Dyck 31 | import Coda.Syntax.Lexer 32 | import Control.Lens as Lens 33 | import Control.Monad.IO.Class 34 | import Data.Char 35 | import Data.List as List 36 | import Data.List.Split (splitOn) 37 | import Data.Monoid 38 | import Data.String 39 | import Data.Text (pack) 40 | import System.Console.Haskeline 41 | import System.Exit 42 | import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) 43 | import Prelude hiding (lex) 44 | 45 | ------------------------------------------------------------------------------ 46 | -- Command 47 | ------------------------------------------------------------------------------ 48 | 49 | data Command = Command 50 | { _cmdName :: String 51 | , _alts :: [String] 52 | , _arg :: Maybe String 53 | , _tabbed :: Maybe (CompletionFunc IO) 54 | , _desc :: String 55 | , _body :: [String] -> String -> IO () 56 | } 57 | 58 | makeClassy ''Command 59 | 60 | cmd :: String -> Command 61 | cmd nm = Command nm [] Nothing Nothing "" $ \_ _ -> return () 62 | 63 | getCommand :: String -> Maybe (Command, [String], String) 64 | getCommand zs = commands ^? 65 | folded. 66 | filtered (\c -> isPrefixOf xs (c^.cmdName) 67 | || anyOf (alts.folded) (isPrefixOf xs) c). 68 | to (,as,ys') 69 | where 70 | (cs, ys) = break isSpace zs 71 | xs:as = splitOn "+" cs 72 | ys' = reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace ys 73 | 74 | executeCommand :: String -> IO () 75 | executeCommand txt = case getCommand txt of 76 | Just (c,args,input) -> view body c args input 77 | Nothing -> do 78 | sayLn $ red (text "Unknown command") <+> bold (text (show (cons ':' txt))) 79 | sayLn $ text "Use" <+> bold (text (show ":?")) <+> "for help." 80 | 81 | showHelp :: [String] -> String -> IO () 82 | showHelp _ _ = sayLn $ vsep (map format commands) where 83 | format c = fill 18 (withArg c) <+> hang 18 (fillSep (text <$> words (c^.desc))) 84 | withArg c = case c^.arg of 85 | Nothing -> bold (char ':' <> text (c^.cmdName)) 86 | Just a -> bold (char ':' <> text (c^.cmdName)) <+> angles (text a) 87 | 88 | commands :: [Command] 89 | commands = 90 | [ cmd "help" & desc .~ "show help" & alts .~ ["?"] & body .~ showHelp 91 | , cmd "quit" & desc .~ "quit" & body.mapped .~ const (liftIO exitSuccess) 92 | , cmd "dyck" & desc .~ "debug dyck language tokenization" & body.mapped .~ \input -> 93 | liftIO $ print (lex (pack input) :: Dyck) 94 | , cmd "version" 95 | & desc .~ "show the compiler version number" 96 | & body .~ \_ _ -> liftIO $ putStrLn version 97 | ] 98 | -------------------------------------------------------------------------------- /lib/coda-console/Coda/Console/Completion.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- | 3 | -- Copyright : (c) Edward Kmett 2017, (c) Edward Kmett and Dan Doel 2012-2013 4 | -- License : BSD2 5 | -- Maintainer: Edward Kmett 6 | -- Stability : experimental 7 | -- Portability: non-portable 8 | -- 9 | -------------------------------------------------------------------- 10 | 11 | module Coda.Console.Completion 12 | ( settings 13 | ) where 14 | 15 | import Control.Lens 16 | import Data.Char 17 | import Data.List 18 | import Data.Set as Set 19 | import Data.Set.Lens 20 | import Data.Monoid 21 | import Coda.Syntax.Token 22 | import Coda.Console.Command 23 | import System.Console.Haskeline 24 | 25 | startingKeywordSet, keywordSet :: Set String 26 | startingKeywordSet = setOf folded startingKeywords 27 | <> setOf (folded.cmdName.to (':':)) commands 28 | keywordSet = setOf folded keywords 29 | 30 | loading :: String -> Bool 31 | loading zs = isPrefixOf ":l" xs && isPrefixOf xs ":load" 32 | where xs = takeWhile (not . isSpace) $ dropWhile isSpace zs 33 | 34 | completed :: (String,String) -> IO (String, [Completion]) 35 | completed (ls, rs) 36 | | ' ' `notElem` ls = completeWith startingKeywordSet (ls, rs) 37 | | loading rls = completeFilename (ls, rs) -- todo upgrade this to use more general per-command parser 38 | | otherwise = completeWith keywordSet (ls, rs) 39 | where rls = reverse ls 40 | 41 | completeWith :: Set String -> CompletionFunc IO 42 | completeWith kws = completeWord Nothing " ,()[]{}" $ \s -> do 43 | -- strs <- use consoleIds 44 | let strs = mempty 45 | return $ (strs <> kws)^..folded.filtered (s `isPrefixOf`).to (\o -> Completion o o True) 46 | 47 | -- | Haskeline settings supporting autocomplete and persistent history 48 | settings :: Settings IO 49 | settings = setComplete completed defaultSettings 50 | { historyFile = Just ".coda_history" 51 | } 52 | -------------------------------------------------------------------------------- /lib/coda-console/Coda/Console/Options.hs: -------------------------------------------------------------------------------- 1 | {-# language TemplateHaskell #-} 2 | 3 | -------------------------------------------------------------------- 4 | -- | 5 | -- Copyright : (c) Edward Kmett 2017 6 | -- License : BSD2 7 | -- Maintainer: Edward Kmett 8 | -- Stability : experimental 9 | -- Portability: non-portable 10 | -- 11 | -------------------------------------------------------------------- 12 | 13 | module Coda.Console.Options 14 | ( ConsoleOptions(..) 15 | , HasConsoleOptions(..) 16 | , parseConsoleOptions 17 | ) where 18 | 19 | import Control.Lens 20 | import Data.Default 21 | import Data.Monoid ((<>)) 22 | import Options.Applicative as Options 23 | 24 | -- | Options for @coda repl@ 25 | data ConsoleOptions = ConsoleOptions 26 | { _consoleOptionsNoHeading :: Bool 27 | , _consoleOptionsNoUnicode :: Bool 28 | } deriving (Eq,Ord,Show,Read) 29 | 30 | instance Default ConsoleOptions where 31 | def = ConsoleOptions False False 32 | 33 | -- | Parse @coda repl@ options 34 | parseConsoleOptions :: Options.Parser ConsoleOptions 35 | parseConsoleOptions = ConsoleOptions 36 | <$> switch (long "no-heading" <> help "Don't show a heading at the top of the REPL") 37 | <*> switch (long "no-unicode" <> help "Disable code-page switching on windows") 38 | 39 | makeClassy ''ConsoleOptions 40 | -------------------------------------------------------------------------------- /lib/coda-console/Coda/Console/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# options_ghc -fno-warn-type-defaults #-} 2 | 3 | -------------------------------------------------------------------- 4 | -- | 5 | -- Copyright : (c) Edward Kmett 2017, (c) Edward Kmett and Dan Doel 2012-2014 6 | -- License : BSD2 7 | -- Maintainer: Edward Kmett 8 | -- Stability : experimental 9 | -- Portability: non-portable 10 | -- 11 | -- General-purpose utilities for pretty printing. 12 | -------------------------------------------------------------------- 13 | 14 | module Coda.Console.Pretty 15 | ( names 16 | , parensIf 17 | , hyph 18 | , prePunctuate 19 | , prePunctuate' 20 | , block 21 | , say 22 | , sayLn 23 | -- , chooseNames 24 | ) where 25 | 26 | import Control.Monad.IO.Class 27 | import Control.Lens 28 | import Data.Maybe (fromMaybe) 29 | import Numeric.Lens 30 | import System.IO 31 | import Text.Hyphenation 32 | import Text.PrettyPrint.ANSI.Leijen hiding ((<>)) 33 | 34 | -- | This is an infinitely large free variable supply you can trim your used variables out of. 35 | names :: [String] 36 | names = map pure az 37 | ++ [ i : review (base 36) j | j <- [1..], i <- az ] where 38 | az = ['a'..'z'] 39 | 40 | -- | Pretty print parentheses 41 | parensIf :: Bool -> Doc -> Doc 42 | parensIf True = parens 43 | parensIf False = id 44 | 45 | -- | Hyphenate a word using standard TeX-style 'english_US' hyphenation. 46 | hyph :: String -> Doc 47 | hyph t = column $ \k -> columns $ \mn -> 48 | let n = fromMaybe 80 mn 49 | (pr,sf) = bimap (fmap fst) (fmap fst) $ span (\ (_,d) -> k + d < n) $ zip xs ls 50 | ls = tail $ scanl (\a b -> a + length b) 0 xs 51 | xs = hyphenate english_US t 52 | in if null pr 53 | then text (concat sf) 54 | else if null sf 55 | then text (concat pr) 56 | else vsep [text (concat pr) <> char '-', text (concat sf)] 57 | 58 | prePunctuate :: Doc -> [Doc] -> [Doc] 59 | prePunctuate _ [ ] = [] 60 | prePunctuate p (d:ds) = d : map (p <+>) ds 61 | 62 | prePunctuate' :: Doc -> Doc -> [Doc] -> [Doc] 63 | prePunctuate' _ _ [ ] = [] 64 | prePunctuate' fp p (d:ds) = (fp <+> d) : map (p <+>) ds 65 | 66 | -- | Format a layout block in explicit style. 67 | block :: [Doc] -> Doc 68 | block [ ] = text "{}" 69 | block (d:ds) = sep (lbrace <+> d : map (semi <+>) ds) <> line <> rbrace 70 | 71 | -- | Pretty print to 'stdout' 72 | say :: MonadIO m => Doc -> m () 73 | say = liftIO . displayIO stdout . renderPretty 0.8 80 -- TODO: options 74 | 75 | -- | Pretty print to 'stdout' with a 'linebreak' after. 76 | sayLn :: MonadIO m => Doc -> m () 77 | sayLn d = say (d <> linebreak) 78 | 79 | {- 80 | chooseNames :: (String -> Bool) -> [Hint] -> [String] -> ([String], [String]) 81 | chooseNames p ahs = go p ahs . filter (\n -> n `notElem` avoid && not (p n)) 82 | where 83 | avoid = [ unpack h | Just h <- ahs ] 84 | 85 | go _ [] supply = ([], supply) 86 | go taken (Nothing : hs) (n:supply) = (n:) `first` go taken hs supply 87 | go taken (Just h : hs) supply@(n:ns) 88 | | taken h' = (n:) `first` go taken hs ns 89 | | otherwise = (h':) `first` go (\x -> x == h' || taken x) hs supply 90 | where h' = unpack h 91 | go _ _ _ = error "PANIC: chooseNames: ran out of names" 92 | -} 93 | -------------------------------------------------------------------------------- /lib/coda-console/Coda/Console/Settings.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- | 3 | -- Copyright : (c) Edward Kmett 2017, (c) Edward Kmett and Dan Doel 2012-2013 4 | -- License : BSD2 5 | -- Maintainer: Edward Kmett 6 | -- Stability : experimental 7 | -- Portability: non-portable 8 | -- 9 | -------------------------------------------------------------------- 10 | 11 | module Coda.Console.Settings 12 | ( settings 13 | ) where 14 | 15 | import Control.Lens 16 | import Data.Char 17 | import Data.List 18 | import Data.Set as Set 19 | import Data.Set.Lens 20 | import Data.Monoid 21 | import Coda.Syntax.Token 22 | import Coda.Console.Command 23 | import Coda.Console.State 24 | import System.Console.Haskeline 25 | 26 | startingKeywordSet, keywordSet :: Set String 27 | startingKeywordSet = setOf folded startingKeywords 28 | <> setOf (folded.cmdName.to (':':)) commands 29 | keywordSet = setOf folded keywords 30 | 31 | loading :: String -> Bool 32 | loading zs = isPrefixOf ":l" xs && isPrefixOf xs ":load" 33 | where xs = takeWhile (not . isSpace) $ dropWhile isSpace zs 34 | 35 | completed :: (String,String) -> IO (String, [Completion]) 36 | completed (ls, rs) 37 | | ' ' `notElem` ls = completeWith startingKeywordSet (ls, rs) 38 | | loading rls = completeFilename (ls, rs) 39 | | otherwise = completeWith keywordSet (ls, rs) 40 | where rls = reverse ls 41 | 42 | completeWith :: Set String -> CompletionFunc Console 43 | completeWith kws = completeWord Nothing " ,()[]{}" $ \s -> do 44 | strs <- use consoleIds 45 | let strs = mempty :: Set String 46 | return $ (strs <> kws)^..folded.filtered (s `isPrefixOf`).to (\o -> Completion o o True) 47 | 48 | -- | Haskeline Settings 49 | settings :: Settings IO 50 | settings = setComplete completed defaultSettings 51 | { historyFile = Just ".ermine_history" 52 | } 53 | -------------------------------------------------------------------------------- /lib/coda-console/Coda/Console/Unicode.hsc: -------------------------------------------------------------------------------- 1 | {-# language CPP #-} 2 | {-# language ForeignFunctionInterface #-} 3 | {-# options_ghc -Wno-redundant-constraints #-} 4 | 5 | -------------------------------------------------------------------- 6 | -- | 7 | -- Copyright : (c) Edward Kmett 2017, (c) Edward Kmett and Dan Doel 2012-2013 8 | -- License : BSD2 9 | -- Maintainer: Edward Kmett 10 | -- Stability : experimental 11 | -- Portability: non-portable 12 | -- 13 | -------------------------------------------------------------------- 14 | 15 | module Coda.Console.Unicode 16 | ( withUnicode 17 | ) where 18 | 19 | import Control.Monad.Catch 20 | 21 | ##ifdef mingw32_HOST_ARCH 22 | ##ifdef i386_HOST_ARCH 23 | ##define USE_CP 24 | import Control.Monad.IO.Class 25 | import System.IO 26 | import Foreign.C.Types 27 | foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool 28 | foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt 29 | ##elif defined(x86_64_HOST_ARCH) 30 | ##define USE_CP 31 | import Control.Monad.IO.Class 32 | import System.IO 33 | import Foreign.C.Types 34 | foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool 35 | foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt 36 | ##endif 37 | ##endif 38 | 39 | -- | Run in a modified codepage where we can print UTF-8 values on Windows. 40 | -- 41 | -- You should probably run the top level of your program in this. 42 | withUnicode :: MonadCatch m => m a -> m a 43 | ##ifdef USE_CP 44 | withUnicode m = do 45 | cp <- liftIO c_GetConsoleCP 46 | enc <- liftIO $ hGetEncoding stdout 47 | let setup = liftIO $ c_SetConsoleCP 65001 >> hSetEncoding stdout utf8 48 | cleanup = liftIO $ maybe (return ()) (hSetEncoding stdout) enc >> c_SetConsoleCP cp 49 | finally (setup >> m) cleanup 50 | ##else 51 | withUnicode m = m 52 | ##endif 53 | -------------------------------------------------------------------------------- /lib/coda-console/coda-console.cabal: -------------------------------------------------------------------------------- 1 | name: coda-console 2 | category: Language 3 | version: 0.0.1 4 | license: BSD2 5 | cabal-version: 2 6 | author: Edward A. Kmett 7 | maintainer: Edward A. Kmett 8 | stability: provisional 9 | homepage: http://github.com/ekmett/coda/ 10 | bug-reports: http://github.com/ekmett/coda/issues 11 | copyright: Copyright (C) 2017 Edward A. Kmett 12 | build-type: Simple 13 | synopsis: Part of the coda compiler 14 | description: This package provides the REPL for the coda compiler. 15 | 16 | source-repository head 17 | type: git 18 | location: git://github.com/ekmett/coda.git 19 | 20 | library 21 | default-language: Haskell2010 22 | ghc-options: -Wall 23 | exposed-modules: 24 | Coda.Console 25 | Coda.Console.Command 26 | Coda.Console.Completion 27 | Coda.Console.Options 28 | Coda.Console.Pretty 29 | Coda.Console.Unicode 30 | build-depends: coda-common, coda-lsp, coda-syntax 31 | build-depends: 32 | ansi-wl-pprint ^>= 0.6, 33 | base, 34 | containers, 35 | data-default, 36 | exceptions >= 0.8.2.1 && < 0.9, 37 | haskeline ^>= 0.7.4, 38 | hyphenation ^>= 0.7, 39 | lens, 40 | mtl, 41 | optparse-applicative >= 0.13 && < 0.15, 42 | split ^>= 0.2, 43 | text 44 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "coda", 3 | "version": "0.1.0", 4 | "description": "Coda language", 5 | "icon": "data/images/logo.png", 6 | "categories": [ 7 | "Languages" 8 | ], 9 | "author": { 10 | "name": "Edward A. Kmett", 11 | "email": "ekmett@gmail.com", 12 | "url": "http://github.com/ekmett" 13 | }, 14 | "repository": { 15 | "type": "git", 16 | "url": "git://github.com/ekmett/coda.git" 17 | }, 18 | "bugs": { 19 | "url": "https://github.com/ekmett/coda/issues", 20 | "email": "ekmett@gmail.com" 21 | }, 22 | "publisher": "ekmett", 23 | "license": "BSD-2-Clause OR Apache-2.0", 24 | "engines": { 25 | "vscode": "^1.12.2" 26 | }, 27 | "scripts": { 28 | "vscode:prepublish": "tsc -p ./", 29 | "build": "tsc -p ./", 30 | "watch": "tsc -watch -p ./", 31 | "postinstall": "node ./node_modules/vscode/bin/install", 32 | "test": "node ./node_modules/vscode/bin/test", 33 | "lint": "tslint code test/code" 34 | }, 35 | "dependencies": { 36 | "path": "^0.12.7", 37 | "vscode-languageclient": "^3.3.0" 38 | }, 39 | "devDependencies": { 40 | "@types/mocha": "^5.2.5", 41 | "@types/node": "^10.9.4", 42 | "tslint": "^5.11.0", 43 | "typescript": "^3.0.3", 44 | "vsce": "^1.47.0", 45 | "vscode": "^1.1.21" 46 | }, 47 | "activationEvents": [ 48 | "onLanguage:coda" 49 | ], 50 | "main": "./out/code/extension.js", 51 | "contributes": { 52 | "languages": [ 53 | { 54 | "id": "coda", 55 | "extensions": [ 56 | ".coda" 57 | ], 58 | "aliases": [ 59 | "Coda" 60 | ], 61 | "configuration": "data/coda.json" 62 | } 63 | ] 64 | } 65 | } 66 | -------------------------------------------------------------------------------- /ref/Async.hs: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------------------------- 2 | --- | 3 | --- Copyright : (c) Edward Kmett 2017 4 | --- License : BSD2 5 | --- Maintainer: Edward Kmett 6 | --- Stability : experimental 7 | --- Portability: non-portable 8 | --- 9 | --------------------------------------------------------------------------------- 10 | 11 | module Coda.Util.Async 12 | ( waitAll 13 | , waitAllSTM 14 | , waitAll_ 15 | , waitAllSTM_ 16 | ) where 17 | 18 | import Control.Concurrent.Async 19 | import Control.Concurrent.STM 20 | 21 | -- | Wait for a bunch of 'Async' computations in the 'STM' monad 22 | waitAllSTM :: [Async a] -> STM [a] 23 | waitAllSTM [] = pure [] 24 | waitAllSTM (x:xs) = (:) <$> (waitSTM x `orElse` (waitAllSTM xs *> retry)) <*> waitAllSTM xs 25 | 26 | -- | Wait for a bunch of 'Async' computations 27 | waitAll :: [Async a] -> IO [a] 28 | waitAll = atomically . waitAllSTM 29 | 30 | -- | Wait for a bunch of 'Async' computations in the 'STM' monad, discarding the results. 31 | waitAllSTM_ :: [Async a] -> STM () 32 | waitAllSTM_ [] = pure () 33 | waitAllSTM_ (x:xs) = (waitSTM x `orElse` (waitAllSTM_ xs *> retry)) *> waitAllSTM_ xs 34 | 35 | -- | Wait for a bunch of 'Async' computations, discarding the results. 36 | waitAll_ :: [Async a] -> IO () 37 | waitAll_ = atomically . waitAllSTM_ 38 | -------------------------------------------------------------------------------- /ref/Foldable.hs: -------------------------------------------------------------------------------- 1 | {-# language BangPatterns #-} 2 | {-# language DefaultSignatures #-} 3 | {-# language FlexibleInstances #-} 4 | {-# language ScopedTypeVariables #-} 5 | {-# language UndecidableInstances #-} 6 | {-# language MultiParamTypeClasses #-} 7 | {-# language FunctionalDependencies #-} 8 | 9 | --------------------------------------------------------------------------------- 10 | -- | 11 | -- Copyright : (c) Edward Kmett 2017 12 | -- License : BSD2 13 | -- Maintainer: Edward Kmett 14 | -- Stability : experimental 15 | -- Portability: non-portable 16 | -- 17 | --------------------------------------------------------------------------------- 18 | 19 | module Coda.Relative.Foldable 20 | ( RelativeFoldable(..) 21 | , RelativeFoldableWithIndex(..) 22 | ) where 23 | 24 | import Coda.Relative.Delta 25 | import Coda.Relative.Class 26 | import Control.Lens 27 | import Data.Functor.Compose 28 | import Data.Functor.Product 29 | import Data.Functor.Sum 30 | import qualified Data.Monoid as Monoid 31 | import Data.Monoid hiding (Product(..), Sum(..)) 32 | import Data.Profunctor.Unsafe 33 | import Data.Proxy 34 | import Data.List.NonEmpty (NonEmpty) 35 | import Data.Map.Strict (Map) 36 | 37 | class RelativeFoldable f where 38 | rfoldMap :: Monoid m => (Delta -> a -> m) -> Delta -> f a -> m 39 | default rfoldMap :: (Foldable f, Monoid m) => (Delta -> a -> m) -> Delta -> f a -> m 40 | rfoldMap f !d = foldMap (f d) 41 | 42 | rfoldr :: (Delta -> a -> r -> r) -> r -> Delta -> f a -> r 43 | rfoldr f z !d = flip appEndo z . rfoldMap (\d' -> Endo #. f d') d 44 | 45 | rlength :: f a -> Int 46 | rlength = Monoid.getSum #. rfoldMap (\_ _ -> Monoid.Sum 1) 0 47 | 48 | rnull :: f a -> Bool 49 | rnull = getAny #. rfoldMap (\_ _ -> Any True) 0 50 | 51 | rtoList :: Relative a => f a -> [a] 52 | rtoList = rfoldr (\d a r -> rel d a : r) [] 0 53 | 54 | instance RelativeFoldable Proxy 55 | instance RelativeFoldable [] 56 | instance RelativeFoldable NonEmpty 57 | instance RelativeFoldable (Map k) 58 | instance RelativeFoldable Identity 59 | instance RelativeFoldable ((,) a) 60 | instance RelativeFoldable (Either a) 61 | 62 | instance (RelativeFoldable f, RelativeFoldable g) => RelativeFoldable (Compose f g) where 63 | rfoldMap f !d = rfoldMap (rfoldMap f) d .# getCompose 64 | 65 | instance (RelativeFoldable f, RelativeFoldable g) => RelativeFoldable (Product f g) where 66 | rfoldMap f !d (Pair x y) = rfoldMap f d x `mappend` rfoldMap f d y 67 | 68 | instance (RelativeFoldable f, RelativeFoldable g) => RelativeFoldable (Sum f g) where 69 | rfoldMap f !d (InL x) = rfoldMap f d x 70 | rfoldMap f !d (InR y) = rfoldMap f d y 71 | 72 | class RelativeFoldable f => RelativeFoldableWithIndex i f | f -> i where 73 | irfoldMap :: Monoid m => (Delta -> i -> a -> m) -> Delta -> f a -> m 74 | default irfoldMap :: (FoldableWithIndex i f, Monoid m) => (Delta -> i -> a -> m) -> Delta -> f a -> m 75 | irfoldMap f !d = ifoldMap (f d) 76 | 77 | irfoldr :: (Delta -> i -> a -> r -> r) -> r -> Delta -> f a -> r 78 | irfoldr f z !d = flip appEndo z . irfoldMap (\d' i -> Endo #. f d' i) d 79 | 80 | instance RelativeFoldableWithIndex a ((,) a) 81 | instance RelativeFoldableWithIndex Int [] 82 | instance RelativeFoldableWithIndex Int NonEmpty 83 | instance RelativeFoldableWithIndex k (Map k) -- relocate keys? 84 | 85 | instance (RelativeFoldableWithIndex i f, RelativeFoldableWithIndex j g) => RelativeFoldableWithIndex (Either i j) (Product f g) where 86 | irfoldMap f d (Pair x y) 87 | = irfoldMap (\d' -> f d' . Left) d x 88 | <> irfoldMap (\d' -> f d' . Right) d y 89 | 90 | instance (RelativeFoldableWithIndex i f, RelativeFoldableWithIndex j g) => RelativeFoldableWithIndex (Either i j) (Sum f g) where 91 | irfoldMap f d (InL x) = irfoldMap (\d' -> f d' . Left) d x 92 | irfoldMap f d (InR y) = irfoldMap (\d' -> f d' . Right) d y 93 | 94 | -------------------------------------------------------------------------------- /ref/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# options_ghc -Wno-orphans #-} 2 | 3 | -------------------------------------------------------------------- 4 | -- | 5 | -- Copyright : (c) Edward Kmett 2017 6 | -- License : BSD2 7 | -- Maintainer: Edward Kmett 8 | -- Stability : experimental 9 | -- Portability: non-portable 10 | -- 11 | -- Missing instances 12 | -------------------------------------------------------------------- 13 | 14 | module Coda.Util.Instances where 15 | 16 | import Control.Applicative 17 | import Data.Void 18 | import Data.Aeson 19 | 20 | instance ToJSON Void where 21 | toJSON = absurd 22 | toEncoding = absurd 23 | 24 | instance FromJSON Void where 25 | parseJSON _ = empty 26 | -------------------------------------------------------------------------------- /ref/Measurement.hs: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------------------------- 2 | -- | 3 | -- Copyright : (c) Edward Kmett 2017 4 | -- License : BSD2 5 | -- Maintainer: Edward Kmett 6 | -- Stability : experimental 7 | -- Portability: non-portable 8 | -- 9 | -- A contravariant functor for working with measured positions 10 | -- 11 | --------------------------------------------------------------------------------- 12 | 13 | module Coda.Relative.Measurement 14 | ( Measurement(..) 15 | , measurement 16 | ) where 17 | 18 | import Coda.Relative.Delta 19 | import Data.Default 20 | import Data.Functor.Contravariant 21 | import Data.Functor.Contravariant.Divisible 22 | import Data.Void 23 | 24 | -- | Position measurements can be combined 25 | newtype Measurement a = Measurement { runMeasurement :: a -> Delta } 26 | 27 | instance Contravariant Measurement where 28 | contramap f (Measurement g) = Measurement (g . f) 29 | 30 | instance Divisible Measurement where 31 | divide f (Measurement g) (Measurement h) = Measurement $ \a -> case f a of 32 | (b, c) -> g b `mappend` h c 33 | conquer = Measurement $ const mempty 34 | 35 | instance Decidable Measurement where 36 | choose f g h = Measurement $ either (runMeasurement g) (runMeasurement h) . f 37 | lose f = Measurement (absurd . f) 38 | 39 | instance Default (Measurement a) where 40 | def = conquer 41 | 42 | -- | We can measure anything with a 'delta' 43 | measurement :: HasDelta a => Measurement a 44 | measurement = Measurement delta 45 | -------------------------------------------------------------------------------- /ref/STM.hs: -------------------------------------------------------------------------------- 1 | {-# language FlexibleContexts #-} 2 | {-# language FlexibleInstances #-} 3 | {-# language UndecidableInstances #-} 4 | 5 | --------------------------------------------------------------------------------- 6 | --- | 7 | --- Copyright : (c) Edward Kmett 2017 8 | --- License : BSD2 9 | --- Maintainer: Edward Kmett 10 | --- Stability : experimental 11 | --- Portability: non-portable 12 | --- 13 | --------------------------------------------------------------------------------- 14 | 15 | module Coda.Util.STM 16 | ( MonadSTM 17 | , liftSTM 18 | ) where 19 | 20 | import Control.Concurrent.STM 21 | import Control.Monad.Base 22 | 23 | -- | A convenient class alias 24 | class MonadBase STM m => MonadSTM m 25 | instance MonadBase STM m => MonadSTM m 26 | 27 | -- | 28 | -- @ 29 | -- 'liftSTM' = 'liftBase' 30 | -- @ 31 | liftSTM :: MonadSTM t => STM a -> t a 32 | liftSTM = liftBase 33 | -------------------------------------------------------------------------------- /ref/Sink.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Copyright : (C) 2017 Edward Kmett 4 | -- License : BSD2 (see the file LICENSE.md) 5 | -- Maintainer : Edward Kmett 6 | -- Stability : experimental 7 | -- Portability : non-portable 8 | -- 9 | ----------------------------------------------------------------------------- 10 | 11 | module Coda.Data.Sink 12 | ( Sink(..) 13 | ) where 14 | 15 | import Data.Default 16 | import Data.Functor.Contravariant 17 | import Data.Functor.Contravariant.Divisible 18 | import Data.Void 19 | 20 | -- | A contravariant message sink 21 | newtype Sink a = Sink { sink :: a -> IO () } 22 | 23 | instance Contravariant Sink where 24 | contramap f (Sink g) = Sink (g . f) 25 | 26 | instance Divisible Sink where 27 | divide f (Sink g) (Sink h) = Sink $ \a -> case f a of 28 | (l, r) -> g l *> h r 29 | conquer = Sink $ const $ pure () 30 | 31 | instance Decidable Sink where 32 | lose f = Sink (absurd . f) 33 | choose f (Sink g) (Sink h) = Sink (either g h . f) 34 | 35 | instance Default (Sink a) where 36 | def = conquer 37 | -------------------------------------------------------------------------------- /ref/View.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveTraversable #-} 2 | {-# language DeriveDataTypeable #-} 3 | {-# language DeriveGeneric #-} 4 | 5 | --------------------------------------------------------------------------------- 6 | --- | 7 | --- Copyright : (c) Edward Kmett 2017 8 | --- License : BSD2 9 | --- Maintainer: Edward Kmett 10 | --- Stability : experimental 11 | --- Portability: non-portable 12 | --- 13 | --------------------------------------------------------------------------------- 14 | 15 | module Coda.Data.View 16 | ( ViewL(..), ViewR(..) 17 | , ViewableL(..), ViewableR(..) 18 | ) where 19 | 20 | import Data.Data 21 | import Data.Default 22 | import GHC.Generics 23 | 24 | data ViewL f a 25 | = EmptyL 26 | | !a :< !(f a) 27 | deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable, Data, Generic, Generic1) 28 | 29 | instance Default (ViewL f a) where 30 | def = EmptyL 31 | 32 | data ViewR f a 33 | = EmptyR 34 | | !(f a) :> !a 35 | deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable, Data, Generic, Generic1) 36 | 37 | instance Default (ViewR f a) where 38 | def = EmptyR 39 | 40 | class ViewableL f where 41 | viewL :: f a -> ViewL f a 42 | 43 | class ViewableR f where 44 | viewR :: f a -> ViewR f a 45 | -------------------------------------------------------------------------------- /ref/coda-change/coda-change.cabal: -------------------------------------------------------------------------------- 1 | name: coda-change 2 | category: Language 3 | version: 0.0.1 4 | license: BSD2 5 | cabal-version: 2 6 | author: Edward A. Kmett 7 | maintainer: Edward A. Kmett 8 | stability: experimental 9 | homepage: http://github.com/ekmett/coda/ 10 | bug-reports: http://github.com/ekmett/coda/issues 11 | copyright: Copyright (C) 2017 Edward A. Kmett 12 | build-type: Simple 13 | synopsis: An experiment in tracking changes between files. 14 | description: See the main coda package for more details. 15 | 16 | source-repository head 17 | type: git 18 | location: git://github.com/ekmett/coda.git 19 | 20 | library change 21 | default-language: Haskell2010 22 | ghc-options: -Wall 23 | exposed-modules: Coda.Syntax.Change 24 | build-depends: base, coda-algebra, coda-common, coda-lsp, data-default, lens, text 25 | -------------------------------------------------------------------------------- /ref/ski/Fun.hs: -------------------------------------------------------------------------------- 1 | {-# language TypeFamilies #-} 2 | module Fun 3 | ( module Term 4 | , Fun(..) 5 | , _S 6 | , _K 7 | , _I 8 | ) where 9 | 10 | import Term 11 | 12 | class Fun t where 13 | term :: Term -> [Term] -> t 14 | 15 | instance Fun Term where 16 | term t xs = foldr (flip app) t xs 17 | 18 | instance (tm ~ Term, Fun t) => Fun (tm -> t) where 19 | term x xs y = term x (y:xs) 20 | 21 | _S, _K, _I :: Fun t => t 22 | _S = term _S0 [] 23 | _K = term _K0 [] 24 | _I = term _I0 [] 25 | -------------------------------------------------------------------------------- /ref/ski/Implements.hs: -------------------------------------------------------------------------------- 1 | main = return () 2 | -------------------------------------------------------------------------------- /ref/ski/Meta.hs: -------------------------------------------------------------------------------- 1 | module Meta where 2 | 3 | data Term = S | S1 Term | S2 Term Term | K | K1 Term | I deriving Show 4 | 5 | infixl 9 `app` 6 | app :: Term -> Term -> Term 7 | app S x = S1 x 8 | app (S1 x) y = S2 x y 9 | app (S2 x y) z = x `app` z `app` (app y z) 10 | app K x = K1 x 11 | app (K1 x) _ = x 12 | app I x = x 13 | 14 | _S0, _K0, _I0 :: Term 15 | _S0 = S 16 | _K0 = K 17 | _I0 = I 18 | -------------------------------------------------------------------------------- /ref/ski/Meta2.hs: -------------------------------------------------------------------------------- 1 | module Meta2 where 2 | 3 | data Neutral = S0 | S1 !Term | S2 !Term !Term | K0 | K1 !Term | I0 deriving Show 4 | data Term = N Neutral | A Neutral !Term !Term 5 | 6 | instance Show Term where 7 | showsPrec d (N l) = showsPrec d l 8 | showsPrec d (A _ l r) = showParen (d > 10) $ showString "A " . showsPrec 11 l . showChar ' ' . showsPrec 11 r 9 | 10 | infixl 9 `call` 11 | call :: Neutral -> Term -> Neutral 12 | call S0 (N K0) = K1 (N I0) -- SK=KI 13 | call S0 x = S1 x 14 | call (S1 x) y = S2 x y 15 | call (S2 x y) z = eval x `call` z `call` app y z 16 | call K0 x = K1 x 17 | call (K1 x) _ = eval x 18 | call I0 x = eval x 19 | 20 | eval :: Term -> Neutral 21 | eval (N t) = t 22 | eval (A t _ _) = t 23 | 24 | -- application with opportunistic optimization 25 | app :: Term -> Term -> Term 26 | app (N S0) (N K0) = N (K1 (N I0)) -- SK=KI 27 | app (N S0) x = N (S1 x) 28 | app (N (S1 x)) y = N (S2 x y) 29 | app (N K0) x = N (K1 x) 30 | app (N I0) x = x 31 | app l r = A (eval l `call` r) l r 32 | 33 | _S0, _K0, _I0 :: Term 34 | _S0 = N S0 35 | _K0 = N K0 36 | _I0 = N I0 37 | -------------------------------------------------------------------------------- /ref/ski/Meta3.hs: -------------------------------------------------------------------------------- 1 | module Meta3 where 2 | 3 | data Neutral 4 | = S | S1 !Term | S2 !Term !Term 5 | | K | K1 !Term 6 | | I 7 | deriving Show 8 | 9 | data Term 10 | = N !Neutral -- known neutral term 11 | | L Neutral -- thunk 12 | 13 | instance Show Term where 14 | showsPrec d (N l) = showsPrec d l 15 | showsPrec d (L l) = showsPrec d l 16 | 17 | infixl 9 `call` 18 | call :: Neutral -> Term -> Neutral 19 | call S (N K) = K1 (N I) -- SK=KI 20 | call S x = S1 x 21 | call (S1 x) y = S2 x y 22 | call (S2 x y) z = eval x `call` z `call` app y z 23 | call K x = K1 x 24 | call (K1 x) _ = eval x 25 | call I x = eval x 26 | 27 | eval :: Term -> Neutral 28 | eval (N t) = t 29 | eval (L t) = t 30 | 31 | app :: Term -> Term -> Term 32 | app (N S) (N K) = N (K1 (N I)) -- SK=KI 33 | app (N S) x = N (S1 x) 34 | app (N (S1 x)) y = N (S2 x y) 35 | app (N K) x = N (K1 x) 36 | app (N I) x = x 37 | app l r = L (eval l `call` r) 38 | 39 | _S0, _K0, _I0 :: Term 40 | _S0 = N S 41 | _K0 = N K 42 | _I0 = N I 43 | -------------------------------------------------------------------------------- /ref/ski/Term.hsig: -------------------------------------------------------------------------------- 1 | signature Term where 2 | 3 | data Term 4 | app :: Term -> Term -> Term 5 | _S0 :: Term 6 | _K0 :: Term 7 | _I0 :: Term 8 | -------------------------------------------------------------------------------- /ref/ski/ski.cabal: -------------------------------------------------------------------------------- 1 | name: ski 2 | version: 0.0.1 3 | license: BSD2 4 | cabal-version: 2 5 | author: Edward A. Kmett 6 | maintainer: Edward A. Kmett 7 | copyright: Copyright (C) 2017 Edward A. Kmett 8 | build-type: Simple 9 | 10 | source-repository head 11 | type: git 12 | location: git://github.com/ekmett/coda.git 13 | 14 | library term 15 | default-language: Haskell2010 16 | ghc-options: -Wall 17 | build-depends: base 18 | signatures: Term 19 | 20 | library fun 21 | default-language: Haskell2010 22 | ghc-options: -Wall 23 | build-depends: base 24 | signatures: Term 25 | exposed-modules: Fun 26 | 27 | library meta 28 | default-language: Haskell2010 29 | ghc-options: -Wall 30 | build-depends: base 31 | exposed-modules: Meta Meta2 Meta3 32 | 33 | library 34 | default-language: Haskell2010 35 | ghc-options: -Wall 36 | build-depends: base, fun, meta 37 | mixins: fun (Fun as Meta.Fun) requires (Term as Meta) 38 | mixins: fun (Fun as Meta2.Fun) requires (Term as Meta2) 39 | mixins: fun (Fun as Meta3.Fun) requires (Term as Meta3) 40 | reexported-modules: 41 | Meta, Meta.Fun, 42 | Meta2, Meta2.Fun, 43 | Meta3, Meta3.Fun 44 | 45 | test-suite implements 46 | default-language: Haskell2010 47 | type: exitcode-stdio-1.0 48 | main-is: Implements.hs 49 | build-depends: base, term, meta 50 | mixins: term requires (Term as Meta) 51 | mixins: term requires (Term as Meta2) 52 | mixins: term requires (Term as Meta3) 53 | -------------------------------------------------------------------------------- /ref/stream/Stream.hsig: -------------------------------------------------------------------------------- 1 | signature Stream where 2 | 3 | data Stream 4 | data Token 5 | data Tokens 6 | 7 | tokenToChunk :: Token -> Tokens 8 | tokensToChunk :: [Token] -> Tokens 9 | chunkToTokens :: Tokens -> [Token] 10 | chunkLength :: Tokens -> Int 11 | chunkEmpty :: Tokens -> Bool 12 | positionAt1 :: Delta -> Token -> Delta 13 | positionAtN :: Delta -> Tokens -> Delta 14 | advance1 :: Delta -> Token -> Delta 15 | advanceN :: Delta -> Tokens -> Delta 16 | take1_ :: Stream -> Maybe (Token, Stream) 17 | takeN_ :: Int -> Stream -> Maybe (Tokens, Stream) 18 | takeWhile_ :: (Token -> Bool) -> Stream -> (Tokens, Stream) 19 | -------------------------------------------------------------------------------- /ref/symantics/L.hs: -------------------------------------------------------------------------------- 1 | -- length of a term 2 | module L where 3 | 4 | type Repr a = Int 5 | 6 | int :: Int -> Repr Int 7 | int _ = 1 8 | 9 | bool :: Bool -> Repr Bool 10 | bool _ = 1 11 | 12 | lam :: (Repr a -> Repr b) -> Repr (a -> b) 13 | lam f = f 0 + 1 14 | 15 | app :: Repr (a -> b) -> Repr a -> Repr b 16 | app f x = f + x + 1 17 | 18 | fix :: (Repr a -> Repr a) -> Repr a 19 | fix f = f 0 + 1 20 | 21 | add :: Repr Int -> Repr Int -> Repr Int 22 | add a b = a + b + 1 23 | 24 | mul :: Repr Int -> Repr Int -> Repr Int 25 | mul a b = a + b + 1 26 | 27 | leq :: Repr Int -> Repr Int -> Repr Bool 28 | leq a b = a + b + 1 29 | 30 | if_ :: Repr Bool -> Repr a -> Repr a -> Repr a 31 | if_ x y z = x + y + z + 1 32 | -------------------------------------------------------------------------------- /ref/symantics/P.hs: -------------------------------------------------------------------------------- 1 | {-# language TypeFamilies #-} 2 | 3 | -- partial evaluation 4 | module P where 5 | 6 | import qualified Control.Monad.Fix as Fix 7 | 8 | import qualified R 9 | import qualified Q 10 | 11 | type family Static a :: * where 12 | Static Int = R.Repr Int 13 | Static Bool = R.Repr Bool 14 | Static (a -> b) = Repr a -> Repr b 15 | 16 | data Repr a 17 | = S (Static a) (Q.Repr a) 18 | | D (Q.Repr a) 19 | 20 | abstr :: Repr a -> Q.Repr a 21 | abstr (S _ q) = q 22 | abstr (D q) = q 23 | 24 | int :: Int -> Repr Int 25 | int i = S (R.int i) (Q.int i) 26 | 27 | bool :: Bool -> Repr Bool 28 | bool b = S (R.bool b) (Q.bool b) 29 | 30 | lam :: (Repr a -> Repr b) -> Repr (a -> b) 31 | lam f = S f $ Q.lam $ \x -> abstr (f (D x)) 32 | 33 | app :: Repr (a -> b) -> Repr a -> Repr b 34 | app f x = case f of 35 | S f' _ -> f' x 36 | _ -> D (Q.app (abstr f) (abstr x)) 37 | 38 | fix :: (Repr a -> Repr a) -> Repr a 39 | fix = Fix.fix 40 | 41 | add :: Repr Int -> Repr Int -> Repr Int 42 | add (S 0 _) x = x 43 | add x (S 0 _) = x 44 | add (S m _) (S n _) = int (R.add m n) 45 | add x y = D (Q.add (abstr x) (abstr y)) 46 | 47 | mul :: Repr Int -> Repr Int -> Repr Int 48 | mul (S 0 _) _ = int 0 49 | mul (S 1 _) x = x 50 | mul _ (S 0 _) = int 0 51 | mul x (S 1 _) = x 52 | mul (S m _) (S n _) = int (R.mul m n) 53 | mul x y = D $ Q.mul (abstr x) (abstr y) 54 | 55 | leq :: Repr Int -> Repr Int -> Repr Bool 56 | leq (S a _) (S b _) = bool (R.leq a b) 57 | leq x y = D $ Q.leq (abstr x) (abstr y) 58 | 59 | if_ :: Repr Bool -> Repr a -> Repr a -> Repr a 60 | if_ (S False _) _ z = z 61 | if_ (S True _) y _ = y 62 | if_ x y z = D $ Q.if_ (abstr x) (abstr y) (abstr z) 63 | -------------------------------------------------------------------------------- /ref/symantics/Q.hs: -------------------------------------------------------------------------------- 1 | {-# language TemplateHaskell #-} 2 | -- staged compilation via template-haskell 3 | module Q where 4 | 5 | import Language.Haskell.TH 6 | import Language.Haskell.TH.Syntax 7 | 8 | type Repr a = Q Exp 9 | 10 | int :: Int -> Repr Int 11 | int = lift 12 | 13 | bool :: Bool -> Repr Bool 14 | bool = lift 15 | 16 | lam :: (Repr a -> Repr b) -> Repr (a -> b) 17 | lam f = do 18 | n <- newName "x" 19 | lamE [varP n] (f (varE n)) 20 | 21 | app :: Repr (a -> b) -> Repr a -> Repr b 22 | app = appE 23 | 24 | fix :: (Repr a -> Repr a) -> Repr a 25 | fix f = do 26 | n <- newName "x" 27 | letE [valD (varP n) (normalB (f (varE n))) []] (varE n) 28 | 29 | add :: Repr Int -> Repr Int -> Repr Int 30 | add x y = varE '(+) `appE` x `appE` y 31 | 32 | mul :: Repr Int -> Repr Int -> Repr Int 33 | mul x y = varE '(*) `appE` x `appE` y 34 | 35 | leq :: Repr Int -> Repr Int -> Repr Bool 36 | leq x y = varE '(<=) `appE` x `appE` y 37 | 38 | if_ :: Repr Bool -> Repr a -> Repr a -> Repr a 39 | if_ = condE 40 | -------------------------------------------------------------------------------- /ref/symantics/R.hs: -------------------------------------------------------------------------------- 1 | -- direct metacircular interpretation 2 | module R where 3 | 4 | import qualified Control.Monad.Fix as Fix 5 | 6 | type Repr a = a 7 | 8 | int :: Int -> Repr Int 9 | int = id 10 | 11 | bool :: Bool -> Repr Bool 12 | bool = id 13 | 14 | lam :: (Repr a -> Repr b) -> Repr (a -> b) 15 | lam = id 16 | 17 | app :: Repr (a -> b) -> Repr a -> Repr b 18 | app = id 19 | 20 | fix :: (Repr a -> Repr a) -> Repr a 21 | fix = Fix.fix 22 | 23 | add :: Repr Int -> Repr Int -> Repr Int 24 | add = (+) 25 | 26 | mul :: Repr Int -> Repr Int -> Repr Int 27 | mul = (*) 28 | 29 | leq :: Repr Int -> Repr Int -> Repr Bool 30 | leq = (<=) 31 | 32 | if_ :: Repr Bool -> Repr a -> Repr a -> Repr a 33 | if_ x y z = if x then y else z 34 | -------------------------------------------------------------------------------- /ref/symantics/RCN.hs: -------------------------------------------------------------------------------- 1 | {-# language RankNTypes, TypeFamilies #-} 2 | -- call-by-need interpreter 3 | module RCN where 4 | 5 | import qualified R 6 | 7 | type family Static a :: * where 8 | Static Int = R.Repr Int 9 | Static Bool = R.Repr Bool 10 | Static (a -> b) = Repr a -> Repr b 11 | 12 | newtype Repr a = Repr { runRepr :: forall r. (Static a -> r) -> r } 13 | 14 | int :: Int -> Repr Int 15 | int x = Repr $ \k -> k x 16 | bool :: Bool -> Repr Bool 17 | bool x = Repr $ \k -> k x 18 | 19 | lam :: (Repr a -> Repr b) -> Repr (a -> b) 20 | lam f = Repr $ \k -> k f 21 | 22 | app :: Repr (a -> b) -> Repr a -> Repr b 23 | app a b = Repr $ \k -> runRepr a $ \f -> runRepr (f b) k 24 | 25 | fix :: (Repr a -> Repr a) -> Repr a 26 | fix = undefined --TODO 27 | -- fix f0 = let fx f n = app (f (lam (fx f))) n in lam (fx f0) 28 | 29 | add :: Repr Int -> Repr Int -> Repr Int 30 | add a b = Repr $ \k -> runRepr a $ \v1 -> runRepr b $ \v2 -> k (v1 + v2) 31 | 32 | mul :: Repr Int -> Repr Int -> Repr Int 33 | mul a b = Repr $ \k -> runRepr a $ \v1 -> runRepr b $ \v2 -> k (v1 * v2) 34 | 35 | leq :: Repr Int -> Repr Int -> Repr Bool 36 | leq a b = Repr $ \k -> runRepr a $ \v1 -> runRepr b $ \v2 -> k (v1 <= v2) 37 | 38 | if_ :: Repr Bool -> Repr a -> Repr a -> Repr a 39 | if_ eb et ee = Repr $ \k -> runRepr eb $ \v -> if v then runRepr et k else runRepr ee k 40 | -------------------------------------------------------------------------------- /ref/symantics/Symantics.hsig: -------------------------------------------------------------------------------- 1 | signature Symantics where 2 | 3 | data Repr a 4 | int :: Int -> Repr Int 5 | bool :: Bool -> Repr Bool 6 | lam :: (Repr a -> Repr b) -> Repr (a -> b) 7 | app :: Repr (a -> b) -> Repr a -> Repr b 8 | fix :: (Repr a -> Repr a) -> Repr a 9 | add :: Repr Int -> Repr Int -> Repr Int 10 | mul :: Repr Int -> Repr Int -> Repr Int 11 | leq :: Repr Int -> Repr Int -> Repr Bool 12 | if_ :: Repr Bool -> Repr a -> Repr a -> Repr a 13 | -------------------------------------------------------------------------------- /ref/symantics/symantics.cabal: -------------------------------------------------------------------------------- 1 | name: symantics 2 | category: Language 3 | version: 0.0.1 4 | license: BSD2 5 | cabal-version: 2 6 | author: Edward A. Kmett 7 | maintainer: Edward A. Kmett 8 | stability: experimental 9 | homepage: http://github.com/ekmett/coda/ 10 | bug-reports: http://github.com/ekmett/coda/issues 11 | copyright: Copyright (C) 2017 Edward A. Kmett 12 | build-type: Simple 13 | synopsis: Finally tagless via backpack 14 | description: Finally tagless via backpack. 15 | 16 | source-repository head 17 | type: git 18 | location: git://github.com/ekmett/coda.git 19 | 20 | library repr 21 | default-language: Haskell2010 22 | ghc-options: -Wall 23 | build-depends: base 24 | signatures: Symantics 25 | 26 | -- metacircular interpreter 27 | library 28 | default-language: Haskell2010 29 | ghc-options: -Wall 30 | build-depends: base, repr, template-haskell 31 | mixins: repr requires (Symantics as R) 32 | mixins: repr requires (Symantics as L) 33 | mixins: repr requires (Symantics as Q) 34 | mixins: repr requires (Symantics as P) 35 | mixins: repr requires (Symantics as RCN) 36 | exposed-modules: P L R Q RCN 37 | -------------------------------------------------------------------------------- /src/algebra/Relative/Delta.hs: -------------------------------------------------------------------------------- 1 | {-# language MultiParamTypeClasses #-} 2 | {-# language TypeFamilies #-} 3 | {-# language FlexibleContexts #-} 4 | {-# language UndecidableInstances #-} 5 | 6 | --------------------------------------------------------------------------------- 7 | -- | 8 | -- Copyright : (c) Edward Kmett 2017-2018 9 | -- License : BSD-2-Clause OR Apache-2.0 10 | -- Maintainer: Edward Kmett 11 | -- Stability : experimental 12 | -- Portability: non-portable 13 | -- 14 | -- Stuff we can measure in UTF-16 code units 15 | --------------------------------------------------------------------------------- 16 | 17 | module Relative.Delta 18 | ( Delta(..) 19 | , HasDelta(..) 20 | , units 21 | , HasMonoidalDelta 22 | , HasOrderedDelta 23 | , HasRelativeDelta 24 | ) where 25 | 26 | import Data.Profunctor.Unsafe 27 | import Data.Text 28 | import Data.Text.Unsafe 29 | 30 | import FingerTree 31 | import Relative.Absolute 32 | import Relative.Class 33 | import Relative.Delta.Type 34 | import Syntax.Alex 35 | 36 | -------------------------------------------------------------------------------- 37 | -- Something that has a delta 38 | -------------------------------------------------------------------------------- 39 | 40 | -- | Something we can measure. 41 | class HasDelta t where 42 | delta :: t -> Delta 43 | 44 | -- | extract the number of utf-16 code units from a delta 45 | units :: HasDelta t => t -> Int 46 | units y = case delta y of 47 | Delta x -> x 48 | 49 | instance HasDelta Delta where 50 | delta = id 51 | 52 | instance HasDelta Text where 53 | delta = Delta . lengthWord16 54 | 55 | instance HasDelta a => HasDelta (Absolute a) where 56 | delta (Absolute a) = delta a 57 | 58 | instance (Measured a, HasDelta (Measure a)) => HasDelta (FingerTree a) where 59 | delta = delta . measure 60 | 61 | instance HasDelta AlexInput where 62 | delta = Delta #. alexInputDelta 63 | 64 | -------------------------------------------------------------------------------- 65 | -- Monoidal deltas 66 | -------------------------------------------------------------------------------- 67 | 68 | -- | 69 | -- 'delta' for this type is a monoid homomorphism 70 | -- 71 | -- @ 72 | -- 'delta' (m '<>' n) = 'delta' m <> 'delta' n 73 | -- 'delta' mempty = 0 74 | -- @ 75 | class (Monoid t, HasDelta t) => HasMonoidalDelta t where 76 | instance HasMonoidalDelta Delta 77 | instance HasMonoidalDelta Text 78 | instance HasMonoidalDelta a => HasMonoidalDelta (Absolute a) 79 | instance (Measured a, HasMonoidalDelta (Measure a)) => HasMonoidalDelta (FingerTree a) 80 | 81 | -------------------------------------------------------------------------------- 82 | -- Monotone deltas 83 | -------------------------------------------------------------------------------- 84 | 85 | -- | 86 | -- Requires that 'delta' is monotone 87 | -- 88 | -- @m <= n@ implies @'delta' m <= 'delta' n@ 89 | class (Ord t, HasDelta t) => HasOrderedDelta t 90 | instance HasOrderedDelta Delta 91 | instance HasOrderedDelta a => HasOrderedDelta (Absolute a) 92 | 93 | -- TODO: supply old instances for all Coda.Relative.* 94 | 95 | -------------------------------------------------------------------------------- 96 | -- Relative deltas 97 | -------------------------------------------------------------------------------- 98 | 99 | -- | 100 | -- 'delta' and 'rel' 101 | -- 102 | -- @ 103 | -- 'delta' ('rel' d p) = d <> 'delta' p 104 | -- @ 105 | class (Relative t, HasDelta t) => HasRelativeDelta t 106 | instance HasRelativeDelta Delta 107 | -------------------------------------------------------------------------------- /src/algebra/Rev.hs: -------------------------------------------------------------------------------- 1 | {-# language CPP #-} 2 | {-# language TemplateHaskell #-} 3 | {-# language TypeFamilies #-} 4 | {-# language FlexibleInstances #-} 5 | {-# language MultiParamTypeClasses #-} 6 | 7 | --------------------------------------------------------------------------------- 8 | -- | 9 | -- Copyright : (c) Edward Kmett 2017-2018 10 | -- License : BSD-2-Clause OR Apache-2.0 11 | -- Maintainer: Edward Kmett 12 | -- Stability : experimental 13 | -- Portability: non-portable 14 | -- 15 | --------------------------------------------------------------------------------- 16 | 17 | module Rev 18 | ( Rev(..) 19 | , _Rev 20 | ) where 21 | 22 | import Relative.Class 23 | import Control.Lens 24 | import Data.Default 25 | 26 | #if __GLASGOW_HASKELL__ < 804 27 | import Data.Semigroup 28 | #endif 29 | 30 | -- reversing a catenable list, etc. 31 | newtype Rev f a 32 | = Rev { runRev :: f a } 33 | deriving (Eq,Ord,Show,Read) 34 | 35 | makePrisms ''Rev 36 | makeWrapped ''Rev 37 | 38 | instance AsEmpty (f a) => AsEmpty (Rev f a) where 39 | _Empty = _Wrapped._Empty 40 | 41 | instance Snoc (f a) (f b) a b => Cons (Rev f a) (Rev f b) a b where 42 | _Cons = _Wrapped._Snoc.swapped.mapping (from _Wrapped) 43 | 44 | instance Cons (f a) (f b) a b => Snoc (Rev f a) (Rev f b) a b where 45 | _Snoc = _Wrapped._Cons.mapping (from _Wrapped).swapped 46 | 47 | instance Default (f a) => Default (Rev f a) where 48 | def = Rev def 49 | 50 | instance Semigroup (f a) => Semigroup (Rev f a) where 51 | Rev a <> Rev b = Rev (b <> a) 52 | 53 | instance Monoid (f a) => Monoid (Rev f a) where 54 | mempty = Rev mempty 55 | mappend (Rev a) (Rev b) = Rev (mappend b a) 56 | 57 | instance Relative (f a) => Relative (Rev f a) where rel d (Rev m) = Rev (rel d m) 58 | 59 | instance RelativeSemigroup (f a) => RelativeSemigroup (Rev f a) 60 | instance RelativeMonoid (f a) => RelativeMonoid (Rev f a) 61 | -------------------------------------------------------------------------------- /src/automata/Automata/DFA.hs: -------------------------------------------------------------------------------- 1 | {-# language GADTs #-} 2 | {-# language OverloadedLists #-} 3 | module Automata.DFA 4 | ( DFA(..) 5 | , reverse, reversed 6 | , complement, complemented 7 | , union 8 | , intersection 9 | , concat 10 | , star 11 | , shrink 12 | , size 13 | -- derivative parsing 14 | , prefix, prefixes 15 | , suffix, suffixes 16 | , check 17 | ) where 18 | 19 | import Control.Lens hiding (reversed) 20 | import Prelude hiding (reverse, concat) 21 | 22 | import Automata.Internal 23 | import qualified Automata.NFA as NFA 24 | import qualified Set.Lazy as Set 25 | 26 | reverse :: DFA a -> DFA a 27 | reverse = over nfa NFA.reverse 28 | 29 | complement :: DFA a -> DFA a 30 | complement (DFA ss is fs d) = DFA ss is (Set.difference ss fs) d 31 | 32 | reversed :: Iso (DFA a) (DFA b) (DFA a) (DFA b) 33 | reversed = iso complement complement 34 | 35 | complemented :: Iso (DFA a) (DFA b) (DFA a) (DFA b) 36 | complemented = iso complement complement 37 | 38 | star :: DFA a -> DFA a 39 | star = over nfa NFA.star 40 | 41 | concat :: DFA a -> DFA a -> DFA a 42 | concat = liftN2 NFA.concat 43 | 44 | union :: DFA a -> DFA a -> DFA a 45 | union = liftN2 NFA.union 46 | 47 | intersection :: DFA a -> DFA a -> DFA a 48 | intersection = liftN2 NFA.intersection 49 | 50 | -- reduce the number of states using knowledge about all possible eventual inputs 51 | shrink :: (Foldable f, Eq a) => f a -> DFA a -> DFA a 52 | shrink as (DFA _ i fs d) = DFA ss' i (Set.intersection fs ss') d where 53 | ss' = reachable (\a s -> Set.singleton (d a s)) as (Set.singleton i) 54 | 55 | size :: DFA a -> Int 56 | size (DFA ss _ _ _) = Set.size ss 57 | 58 | -------------------------------------------------------------------------------- 59 | -- derivative parsing 60 | -------------------------------------------------------------------------------- 61 | 62 | -- feed a single prefix 63 | prefix :: a -> DFA a -> DFA a 64 | prefix a (DFA ss i fs d) = DFA ss (d a i) fs d 65 | 66 | -- feed a long prefix 67 | prefixes :: [a] -> DFA a -> DFA a 68 | prefixes as (DFA ss i fs d) = DFA ss (foldl (flip d) i as) fs d 69 | 70 | -- feed a single suffix 71 | suffix :: DFA a -> a -> DFA a 72 | suffix m a = over nfa (`NFA.suffix` a) m 73 | 74 | -- feed a long suffix 75 | suffixes :: DFA a -> [a] -> DFA a 76 | suffixes m as = over nfa (`NFA.suffixes` as) m 77 | 78 | -- check to see if we accept the empty string 79 | check :: DFA a -> Bool 80 | check (DFA _ i fs _) = Set.member i fs 81 | -------------------------------------------------------------------------------- /src/automata/Automata/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# language GADTs #-} 2 | {-# language OverloadedLists #-} 3 | module Automata.Internal where 4 | 5 | import Control.Lens 6 | import Data.Functor.Contravariant.Divisible 7 | import Data.Void 8 | 9 | import qualified Set.Lazy as Set 10 | import Set.Lazy (Set) 11 | 12 | data NFA a where 13 | NFA :: Ord s => Set s -> Set s -> Set s -> (a -> s -> Set s) -> NFA a 14 | 15 | instance Contravariant NFA where 16 | contramap f (NFA ss is fs d) = NFA ss is fs (d . f) 17 | 18 | -- divide computes the intersection of two NFAs 19 | instance Divisible NFA where 20 | conquer = NFA [()] [()] [()] (\_ _ -> [()]) 21 | divide f (NFA ss is fs d) (NFA ss' is' fs' d') 22 | = NFA (Set.product ss ss') (Set.product is is') (Set.product fs fs') $ \ a (s,s') -> case f a of 23 | (b, c) -> Set.product (d b s) (d' c s') 24 | 25 | -- decide computes an nfa disjoint union 26 | instance Decidable NFA where 27 | lose f = NFA ([] :: Set Void) [] [] (absurd . f) 28 | choose f (NFA ss is fs d) (NFA ss' is' fs' d') 29 | = NFA (Set.sum ss ss') (Set.sum is is') (Set.sum fs fs') $ \a s -> case f a of 30 | Left b -> case s of 31 | Left s' -> Set.mapMonotonic Left (d b s') 32 | Right{} -> Set.empty 33 | Right c -> case s of 34 | Left{} -> Set.empty 35 | Right s' -> Set.mapMonotonic Right (d' c s') 36 | 37 | data DFA a where 38 | DFA :: Ord s => Set s -> s -> Set s -> (a -> s -> s) -> DFA a 39 | 40 | instance Contravariant DFA where 41 | contramap f (DFA ss is fs d) = DFA ss is fs (d . f) 42 | 43 | instance Divisible DFA where 44 | conquer = DFA [()] () [()] $ \_ _ -> () 45 | divide = liftN2 . divide 46 | 47 | instance Decidable DFA where 48 | lose = nfa2dfa . lose 49 | choose = liftN2 . choose 50 | 51 | dfa :: Iso (NFA a) (NFA b) (DFA a) (DFA b) 52 | dfa = iso nfa2dfa dfa2nfa 53 | 54 | nfa :: Iso (DFA a) (DFA b) (NFA a) (NFA b) 55 | nfa = iso dfa2nfa nfa2dfa 56 | 57 | liftN2 :: (NFA a -> NFA b -> NFA c) -> DFA a -> DFA b -> DFA c 58 | liftN2 f = over nfa . f . dfa2nfa 59 | 60 | nfa2dfa :: NFA a -> DFA a 61 | nfa2dfa (NFA ss is fs d) = DFA ss' is (Set.filter (intersects fs) ss') d' where 62 | ss' = Set.powerset ss 63 | d' = nondet d 64 | 65 | dfa2nfa :: DFA a -> NFA a 66 | dfa2nfa (DFA ss is fs d) = NFA ss (Set.singleton is) fs $ \a s -> Set.singleton $ d a s 67 | 68 | -- perform an NFA step 69 | nondet :: Ord s => (a -> s -> Set s) -> a -> Set s -> Set s 70 | nondet f a = foldMap (f a) 71 | 72 | -- perform several NFA steps 73 | nondets :: Ord s => (a -> s -> Set s) -> [a] -> Set s -> Set s 74 | nondets f as z = foldr (nondet f) z as 75 | 76 | intersects :: Ord s => Set s -> Set s -> Bool 77 | intersects xs ys = not $ Set.null $ Set.intersection xs ys 78 | 79 | -- ambiguous glyphs 80 | reachable :: (Foldable f, Ord s) => (a -> s -> Set s) -> f a -> Set s -> Set s 81 | reachable d as = fixSet $ \ s -> foldMap (\t -> foldMap (`d` t) as) s `Set.union` s where 82 | fixSet f a 83 | | a == a' = a 84 | | otherwise = fixSet f a' 85 | where a' = f a 86 | {-# inline reachable #-} 87 | -------------------------------------------------------------------------------- /src/automata/Automata/NFA.hs: -------------------------------------------------------------------------------- 1 | {-# language GADTs #-} 2 | {-# language OverloadedLists #-} 3 | {-# language ViewPatterns #-} 4 | module Automata.NFA 5 | ( NFA(..) 6 | , reverse, reversed 7 | , complement, complemented 8 | , union 9 | , intersection 10 | , concat 11 | , star 12 | , shrink 13 | , size 14 | -- derivative parsing 15 | , prefix, prefixes 16 | , suffix, suffixes 17 | , check 18 | ) where 19 | 20 | import Control.Lens hiding (reversed) 21 | import qualified Data.List as List 22 | import Prelude hiding (reverse, concat) 23 | 24 | import Automata.Internal 25 | import qualified Set.Lazy as Set 26 | 27 | -- nfa reversal 28 | reverse :: NFA a -> NFA a 29 | reverse (NFA ss i f d) = NFA ss f i $ \ a t -> Set.filter (Set.member t . d a) ss 30 | 31 | -- nfa complement 32 | complement :: NFA a -> NFA a 33 | complement = dfa2nfa . go . nfa2dfa where 34 | go (DFA ss is fs d) = DFA ss is (Set.difference ss fs) d 35 | 36 | reversed :: Iso (NFA a) (NFA b) (NFA a) (NFA b) 37 | reversed = iso complement complement 38 | 39 | complemented :: Iso (NFA a) (NFA b) (NFA a) (NFA b) 40 | complemented = iso complement complement 41 | 42 | -- kleene star 43 | star :: NFA a -> NFA a 44 | star (NFA ss is fs d) = NFA ss is fs $ \a (d a -> r) -> 45 | if intersects fs r 46 | then Set.union r is 47 | else r 48 | 49 | -- concatenate two automata 50 | concat :: NFA a -> NFA a -> NFA a 51 | concat (NFA ss is fs d) 52 | (NFA ss' (Set.mapMonotonic Right -> is') (Set.mapMonotonic Right -> fs') d') 53 | = NFA (Set.sum ss ss') (Set.mapMonotonic Left is) fs' $ \a s -> case s of 54 | Right s' -> Set.mapMonotonic Right (d' a s') 55 | Left (d a -> r) | r' <- Set.mapMonotonic Left r -> 56 | if intersects r fs 57 | then Set.union r' is' 58 | else r' 59 | 60 | -- nfa union 61 | union :: NFA a -> NFA a -> NFA a 62 | union (NFA ss is fs d) (NFA ss' is' fs' d') 63 | = NFA (Set.sum ss ss') (Set.sum is is') (Set.sum fs fs') $ \a s -> case s of 64 | Left s' -> Set.mapMonotonic Left (d a s') 65 | Right s' -> Set.mapMonotonic Right (d' a s') 66 | 67 | -- nfa intersection 68 | intersection :: NFA a -> NFA a -> NFA a 69 | intersection (NFA ss is fs d) (NFA ss' is' fs' d') 70 | = NFA (Set.product ss ss') (Set.product is is') (Set.product fs fs') $ \ a (s,s') -> Set.product (d a s) (d' a s') 71 | 72 | -- reduce the number of states using knowledge about all possible eventual inputs 73 | shrink :: (Foldable f, Eq a) => f a -> NFA a -> NFA a 74 | shrink as (NFA _ is fs d) = NFA ss' is (Set.intersection fs ss') d where 75 | ss' = reachable d as is 76 | -- TODO: filter d w/ as to avoid bogus states? 77 | 78 | size :: NFA a -> Int 79 | size (NFA ss _ _ _) = Set.size ss 80 | 81 | -------------------------------------------------------------------------------- 82 | -- derivative parsing 83 | -------------------------------------------------------------------------------- 84 | 85 | -- feed a single prefix 86 | prefix :: a -> NFA a -> NFA a 87 | prefix a (NFA ss is fs d) = NFA ss (nondet d a is) fs d 88 | 89 | -- feed a long prefix 90 | prefixes :: [a] -> NFA a -> NFA a 91 | prefixes as (NFA ss is fs d) = NFA ss (nondets d as is) fs d 92 | 93 | -- feed a single suffix 94 | suffix :: NFA a -> a -> NFA a 95 | suffix (NFA ss is fs d) a = NFA ss is (Set.filter (intersects fs . d a) ss) d 96 | 97 | -- feed a long suffix 98 | suffixes :: NFA a -> [a] -> NFA a 99 | suffixes (NFA ss is fs d) as = NFA ss is (nondets d' (List.reverse as) fs) d where 100 | d' a t = Set.filter (Set.member t . d a) ss 101 | 102 | -- check to see if we accept the empty string 103 | check :: NFA a -> Bool 104 | check (NFA _ is fs _) = intersects is fs 105 | -------------------------------------------------------------------------------- /src/automata/Automata/Presburger.hs: -------------------------------------------------------------------------------- 1 | {-# language BangPatterns, RankNTypes #-} 2 | module Automata.Presburger where 3 | 4 | import Control.Lens 5 | import Data.Bits hiding (complement) 6 | import Data.Functor.Contravariant.Divisible 7 | import GHC.Arr 8 | import Numeric.Natural 9 | import Prelude hiding (reverse) 10 | import Utils.Containers.Internal.StrictPair 11 | 12 | import Automata.Internal 13 | import Automata.NFA 14 | import Set.Lazy as Set 15 | 16 | type Var = Int -- "bad" is -1, as testBit x (-1) = 0 17 | type Vec = Natural -- bit vector 18 | 19 | var :: Eq a => a -> [a] -> Var 20 | var a0 as0 = go 0 a0 as0 where 21 | go !_ _ [] = -1 22 | go i a (b:bs) 23 | | a == b = i 24 | | otherwise = go (i+1) a bs 25 | 26 | -- common boolean sets 27 | sb, sf, st :: Set Bool 28 | sb = Set.fromDistinctAscList [False, True] 29 | sf = Set.singleton False 30 | st = Set.singleton True 31 | 32 | given :: Bool -> a -> Set a 33 | given True a = Set.singleton a 34 | given False _ = Set.empty 35 | 36 | -- i + j = k 37 | add :: Var -> Var -> Var -> NFA Vec 38 | add i j k = reverse $ NFA sb sf sf step where 39 | step xs b = case plus (testBit xs i) (testBit xs j) b of 40 | r :*: c -> given (testBit xs k == r) c 41 | plus a b c = case half a b of 42 | s1 :*: c1 -> case half s1 c of 43 | s2 :*: c2 -> s2 :*: (c1 || c2) 44 | half a b = xor a b :*: (a && b) 45 | 46 | -- i + j + k = l 47 | add3 :: Var -> Var -> Var -> Var -> NFA Vec 48 | add3 i j k l = reverse $ NFA s3 s0 s0 step where 49 | step xs s = case plus3 (testBit xs i) (testBit xs j) (testBit xs k) s of 50 | r :*: c -> given (testBit xs l == r) c 51 | plus3 a b c d = r :*: div (d + fromEnum a + fromEnum b + fromEnum c - fromEnum r) 2 where r = a `xor` b `xor` c `xor` toEnum (mod d 2) 52 | s3 = Set.fromDistinctAscList [0,1,2] 53 | s0 = Set.singleton (0 :: Int) 54 | 55 | eq :: Var -> Var -> NFA Vec 56 | eq i j = NFA su su su $ \xs _ -> if testBit xs i == testBit xs j then su else empty 57 | where su = Set.singleton () 58 | 59 | data Cmp = Never | Eq | Lt | Le | Gt | Ge | Ne | Always deriving (Eq,Ord,Show,Read,Ix,Bounded,Enum) 60 | 61 | cmp :: (forall a. Ord a => a -> a -> Bool) -> Var -> Var -> NFA Vec 62 | cmp f i j = case toEnum (a + b + c) of 63 | Never -> complement conquer 64 | Eq -> eq i j 65 | Lt -> go st st empty 66 | Le -> go sb st empty 67 | Gt -> go st empty st 68 | Ge -> go sb empty st 69 | Ne -> complement (eq i j) 70 | Always -> conquer 71 | where 72 | a = if f True False then 4 else 0 73 | b = if f False True then 2 else 0 74 | c = if f False False then 1 else 0 75 | go :: Set Bool -> Set Bool -> Set Bool -> NFA Vec 76 | go fs fft ftf = NFA sb sf fs step where 77 | step _ True = st 78 | step xs False = case testBit xs i :*: testBit xs j of 79 | True :*: False -> ftf 80 | False :*: True -> fft 81 | _ -> sf 82 | 83 | exists :: Var -> NFA Vec -> NFA Vec 84 | exists n (NFA ss is fs d) = NFA ss (reachable d [0,bit n] is) fs $ \a s -> d a s `Set.union` d (setBit a n) s 85 | 86 | forall :: Var -> NFA Vec -> NFA Vec 87 | forall = over complemented . exists 88 | 89 | data Bind = E | F 90 | 91 | type Prefix = [Bind] 92 | 93 | quantify :: Prefix -> NFA Vec -> NFA Vec 94 | quantify = go 0 where 95 | go i (E:xs) b = exists i $ go (i+1) xs b 96 | go i (F:xs) b = forall i $ go (i+1) xs b 97 | go _ [] b = b 98 | 99 | -- | is there a largest natural? 100 | -- 101 | -- >>> check inf_exists 102 | -- False 103 | inf_exists :: NFA Vec 104 | inf_exists = quantify [E,F] $ cmp (>=) 0 1 105 | 106 | -- | is there a smallest natural? 107 | -- 108 | -- >>> check zero_exists 109 | -- True 110 | zero_exists :: NFA Vec 111 | zero_exists = quantify [E,F] $ cmp (<=) 0 1 112 | 113 | -- | forall n. exists m. 2 * n == m 114 | -- 115 | -- >>> check times2_exists 116 | -- True 117 | times2_exists :: NFA Vec 118 | times2_exists = quantify [F,E] $ add 0 0 1 119 | 120 | -- | forall n. exists m. 2 * m == n 121 | -- 122 | -- >>> check div2_exists 123 | -- False 124 | div2_exists :: NFA Vec 125 | div2_exists = quantify [F,E] $ add 1 1 0 126 | -------------------------------------------------------------------------------- /src/coda/LLVM.hs: -------------------------------------------------------------------------------- 1 | module LLVM 2 | ( fun 3 | ) where 4 | 5 | import Data.Foldable (toList) 6 | import Data.Traversable (mapAccumL) 7 | import LLVM.AST 8 | import LLVM.IRBuilder as IR 9 | 10 | -- | A slightly safer version of 'IR.function' using the encoding trick 11 | -- from the @ad@ package 12 | fun 13 | :: (MonadModuleBuilder m, Traversable f) 14 | => Name -- ^ Function name 15 | -> f (Type, ParameterName) -- ^ Parameter types and name suggestions 16 | -> Type -- ^ Return type 17 | -> (f Operand -> IRBuilderT m ()) -- ^ Function body builder 18 | -> m Operand 19 | fun n as r f = IR.function n (toList as) r $ \xs -> f (refill xs as) 20 | 21 | -- | assumes list length and container length match 22 | refill :: Traversable f => [a] -> f b -> f a 23 | refill = fmap snd . mapAccumL (\(a:as') _ -> (as', a)) 24 | -------------------------------------------------------------------------------- /src/coda/Syntax/Alex.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# language BangPatterns #-} 3 | {-# language TypeFamilies #-} 4 | {-# language DeriveGeneric #-} 5 | {-# language DeriveDataTypeable #-} 6 | 7 | --------------------------------------------------------------------------------- 8 | -- | 9 | -- Copyright : (c) Edward Kmett 2017-2018 10 | -- License : BSD-2-Clause OR Apache-2.0 11 | -- Maintainer: Edward Kmett 12 | -- Stability : experimental 13 | -- Portability: non-portable 14 | -- 15 | -- A simple input adapter that allows @alex@ to work with 'Text' 16 | --------------------------------------------------------------------------------- 17 | 18 | module Syntax.Alex 19 | ( AlexInput(..) 20 | , AlexInputState(..) 21 | , alexGetByte 22 | ) where 23 | 24 | import Data.Bits 25 | import Data.Data 26 | import Data.String 27 | import Data.Text 28 | import Data.Text.Unsafe as Text 29 | import Data.Word (Word8) 30 | import GHC.Generics 31 | 32 | -- $setup 33 | -- >>> :set -XOverloadedStrings -XOverloadedLists 34 | -- >>> import Data.List as List (unfoldr) 35 | 36 | data AlexInputState 37 | = S0 | S1 | S2 | S3 38 | deriving (Eq, Ord, Show, Read, Data, Generic) 39 | 40 | -- | 41 | -- Invariants: 42 | -- 43 | -- @ 44 | -- 'delta' >= 0 45 | -- @ 46 | data AlexInput = AlexInput 47 | { alexInputState :: !AlexInputState 48 | , alexInputPrevChar :: {-# unpack #-} !Char 49 | , alexInputDelta :: {-# unpack #-} !Int 50 | , alexInputText :: {-# unpack #-} !Text 51 | } deriving (Eq, Ord, Show, Read, Data, Generic) 52 | 53 | instance IsString AlexInput where 54 | fromString = AlexInput S0 '\n' 0 . fromString 55 | 56 | fromText :: Text -> AlexInput 57 | fromText = AlexInput S0 '\n' 0 58 | {-# inline conlike fromText #-} 59 | 60 | ok :: a -> b -> Maybe (a,b) 61 | ok !a !b = Just (a,b) 62 | 63 | -- | 64 | -- >>> Prelude.take 20 $ List.unfoldr alexGetByte "hello world" 65 | -- [104,101,108,108,111,32,119,111,114,108,100] 66 | alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) 67 | alexGetByte (AlexInput !s !c !d !t) = case s of 68 | S3 | i <- fromEnum c -> ok (fromIntegral $ 0x80 + unsafeShiftR i 12 .&. 0x3f) (AlexInput S2 c (d+1) t) 69 | S2 | i <- fromEnum c -> ok (fromIntegral $ 0x80 + unsafeShiftR i 6 .&. 0x3f) (AlexInput S1 c (d+1) t) 70 | S1 | i <- fromEnum c -> ok (fromIntegral $ 0x80 + i .&. 0x3f) (AlexInput S0 c (d+1) t) 71 | S0 | d < Text.lengthWord16 t -> case Text.iter t d of 72 | Text.Iter c' d' 73 | | i' <= 0x7f -> ok (fromIntegral i') (AlexInput S0 c' (d+d') t) 74 | | i' <= 0x7ff -> ok (fromIntegral $ 0xc0 + unsafeShiftR i' 6) (AlexInput S1 c' (d+d') t) 75 | | i' <= 0xffff -> ok (fromIntegral $ 0xe0 + unsafeShiftR i' 12) (AlexInput S2 c' (d+d') t) 76 | | otherwise -> ok (fromIntegral $ 0xf0 + unsafeShiftR i' 18) (AlexInput S3 c' (d+d') t) 77 | where i' = fromEnum c' 78 | | otherwise -> Nothing 79 | -------------------------------------------------------------------------------- /src/coda/Syntax/Error.hs: -------------------------------------------------------------------------------- 1 | {-# language BangPatterns #-} 2 | {-# language OverloadedStrings #-} 3 | {-# language FlexibleContexts #-} 4 | 5 | module Syntax.Error 6 | ( ppError 7 | ) where 8 | 9 | import Data.Maybe (isNothing) 10 | import Data.List as List 11 | import Data.List.NonEmpty as NE 12 | import Data.Proxy 13 | import qualified Data.Set as E 14 | import Data.Text as Text 15 | import Data.Text.Prettyprint.Doc 16 | import Data.Text.Prettyprint.Doc.Render.Terminal 17 | import Text.Megaparsec.Error 18 | import Text.Megaparsec.Stream 19 | import Text.Megaparsec.Pos 20 | import Syntax.Located 21 | 22 | ppError :: (Ord a, ShowToken (Located a), ShowErrorComponent e) => Text -> ParseError (Located a) e -> Doc AnsiStyle 23 | ppError s e = vsep 24 | [ sourcePosStackPrettier (errorPos e) <> ":" 25 | , pretty padding <> bar 26 | , pretty lineNumber <+> bar <+> rline 27 | , pretty padding <> bar <+> pretty rpadding <> cursor 28 | , parseErrorTextPrettier e 29 | ] where 30 | bar = annotate (color Yellow) "|" 31 | cursor = annotate (color Green) "^" -- TODO: extend as a span to the right 32 | epos = NE.last (errorPos e) 33 | lineNumber = show $ unPos $ sourceLine epos 34 | padding = spaces $ Prelude.length lineNumber + 1 35 | rpadding = spaces $ unPos (sourceColumn epos) - 1 36 | spaces n = justifyLeft n ' ' "" 37 | rline = case rline' of 38 | [] -> annotate (color Red) "" 39 | xs -> pretty $ expandTab (mkPos 8) xs 40 | rline' = fmap tokenAsChar . chunkToTokens (Proxy :: Proxy Text) $ selectLine (sourceLine epos) s 41 | 42 | selectLine 43 | :: Pos -- ^ Number of line to select 44 | -> Text -- ^ Input stream 45 | -> Text -- ^ Selected line 46 | selectLine l = go pos1 where 47 | go !n !s 48 | | n == l = fst (takeWhile_ notNewline s) 49 | | otherwise = go (n <> pos1) (stripNewline $ snd (takeWhile_ notNewline s)) 50 | notNewline = not . tokenIsNewline 51 | stripNewline s = maybe s snd (take1_ s) 52 | 53 | expandTab :: Pos -> String -> String 54 | expandTab w' = go 0 where 55 | go 0 [] = [] 56 | go 0 ('\t':xs) = go w xs 57 | go 0 (x:xs) = x : go 0 xs 58 | go !n xs = ' ' : go (n - 1) xs 59 | w = unPos w' 60 | 61 | parseErrorTextPrettier :: (Ord t, ShowToken t, ShowErrorComponent e) 62 | => ParseError t e -- ^ Parse error to render 63 | -> Doc AnsiStyle -- ^ Result of rendering 64 | parseErrorTextPrettier (TrivialError _ us ps) = 65 | if isNothing us && E.null ps 66 | then "unknown parse error\n" 67 | else messageItemsPrettier "unexpected " (maybe E.empty E.singleton us) <> 68 | messageItemsPrettier "expecting " ps 69 | parseErrorTextPrettier (FancyError _ xs) = 70 | if E.null xs 71 | then "unknown fancy parse error\n" 72 | else vsep (pretty . showErrorComponent <$> E.toAscList xs) 73 | 74 | messageItemsPrettier :: ShowErrorComponent a 75 | => Doc AnsiStyle -- ^ Prefix to prepend 76 | -> E.Set a -- ^ Collection of messages 77 | -> Doc AnsiStyle -- ^ Result of rendering 78 | messageItemsPrettier prefix ts 79 | | E.null ts = mempty 80 | | otherwise = 81 | let f = orList . NE.fromList . fmap pretty . E.toAscList . E.map showErrorComponent 82 | in prefix <> f ts <> "\n" 83 | 84 | orList :: NonEmpty (Doc a) -> Doc a 85 | orList (x:|[]) = x 86 | orList (x:|[y]) = x <> " or " <> y 87 | orList xs = sep (List.intersperse ", " (NE.init xs)) <> ", or " <> NE.last xs 88 | 89 | sourcePosStackPrettier :: NonEmpty SourcePos -> Doc AnsiStyle 90 | sourcePosStackPrettier ms = mconcat (f <$> rest) <> sourcePosPrettier pos 91 | where 92 | pos :| rest' = ms 93 | rest = Prelude.reverse rest' 94 | f p = "in file included from " <> sourcePosPrettier p <> ",\n" 95 | 96 | sourcePosPrettier :: SourcePos -> Doc AnsiStyle 97 | sourcePosPrettier (SourcePos n l c) 98 | | Prelude.null n = annotate bold showLC 99 | | otherwise = annotate bold $ pretty n <> ":" <> showLC 100 | where showLC = pretty $ show (unPos l) <> ":" <> show (unPos c) 101 | -------------------------------------------------------------------------------- /src/coda/Syntax/Located.hs: -------------------------------------------------------------------------------- 1 | {-# language TypeFamilies #-} 2 | {-# language DeriveTraversable #-} 3 | {-# language FlexibleInstances #-} 4 | 5 | module Syntax.Located 6 | ( Located(..) 7 | ) where 8 | 9 | import Control.Comonad 10 | import Data.List (uncons) 11 | import Text.Megaparsec.Stream 12 | import Text.Megaparsec.Pos 13 | 14 | -- megaparsec doesn't give the stream to anything useful here, so let's duplicate some effort =( 15 | data Located a = Located !SourcePos a !SourcePos 16 | deriving (Functor, Foldable, Traversable, Eq, Ord, Show) 17 | 18 | instance Comonad Located where 19 | extract (Located _ a _) = a 20 | duplicate w@(Located p _ q) = Located p w q 21 | 22 | instance Ord a => Stream [Located a] where -- Ord? really? 23 | type Token [Located a] = Located a 24 | type Tokens [Located a] = [Located a] 25 | tokenToChunk _ t = [t] 26 | tokensToChunk _ = id 27 | chunkToTokens _ = id 28 | chunkLength _ = length 29 | chunkEmpty _ = null 30 | positionAt1 _ _ (Located p _ _) = p 31 | positionAtN _ s [] = s 32 | positionAtN _ _ (Located p _ _:_) = p 33 | advance1 _ _ _ (Located _ _ q) = q 34 | advanceN _ _ s [] = s 35 | advanceN _ _ _ xs = case last xs of Located _ _ q -> q 36 | take1_ = uncons 37 | takeN_ n s 38 | | n <= 0 = Just ([],s) 39 | | null s = Nothing 40 | | otherwise = Just (splitAt n s) 41 | takeWhile_ = span 42 | -------------------------------------------------------------------------------- /src/coda/Syntax/Name.hs: -------------------------------------------------------------------------------- 1 | module Syntax.Name 2 | ( Name(..) 3 | , isBound, isFree 4 | ) where 5 | 6 | import Data.String 7 | import Data.Text.Short as T 8 | 9 | data Name 10 | = Free ShortText Integer 11 | | Bound Integer Integer 12 | deriving (Eq,Ord,Show) 13 | 14 | isBound :: Name -> Bool 15 | isBound Bound{} = True 16 | isBound _ = False 17 | 18 | isFree :: Name -> Bool 19 | isFree Free{} = True 20 | isFree _ = False 21 | 22 | {- 23 | instance Fancy Name where 24 | fancy (Free x n) | T.null x = annotate StyleName $ pretty '_' <> pretty n 25 | fancy (Free x 0) = annotate StyleName $ pretty (toText x) 26 | fancy (Free x n) = annotate StyleName $ pretty (toText x) <> pretty n 27 | fancy (Bound x y) = annotate StyleName $ pretty x <> pretty '@' <> pretty y 28 | -} 29 | 30 | instance IsString Name where 31 | fromString n = Free (T.fromString n) 0 32 | -------------------------------------------------------------------------------- /src/common/Algebra/Ordered.hs: -------------------------------------------------------------------------------- 1 | module Algebra.Ordered 2 | ( OrderedMonoid 3 | ) where 4 | 5 | import Relative.Delta.Type 6 | import Data.Monoid 7 | 8 | -------------------------------------------------------------------------------- 9 | -- Ordered monoids 10 | -------------------------------------------------------------------------------- 11 | 12 | -- | 13 | -- An . 14 | -- 15 | -- @x '<=' y@ implies @z '<>' x '<=' z '<>' y@ and @x '<>' z '<=' y' <>' z@ 16 | class (Ord t, Monoid t) => OrderedMonoid t 17 | 18 | instance OrderedMonoid Delta 19 | instance OrderedMonoid Any 20 | instance OrderedMonoid All 21 | instance OrderedMonoid a => OrderedMonoid (Dual a) 22 | instance Ord a => OrderedMonoid [a] 23 | instance Ord a => OrderedMonoid (First a) 24 | instance Ord a => OrderedMonoid (Last a) 25 | instance OrderedMonoid a => OrderedMonoid (Maybe a) 26 | instance OrderedMonoid () 27 | instance (OrderedMonoid a, OrderedMonoid b) => OrderedMonoid (a, b) 28 | 29 | -- TODO: 30 | -- instance (Ord a, Bounded a) => OrderedMonoid (Min a) 31 | -- instance (Ord a, Bounded a) => OrderedMonoid (Max a) 32 | -- instance Ord a => OrderedSemigroup (NonEmpty a) 33 | 34 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /src/common/Algebra/Zero.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveDataTypeable #-} 2 | {-# language PatternSynonyms #-} 3 | {-# language DeriveGeneric #-} 4 | {-# language DeriveTraversable #-} 5 | {-# language FlexibleInstances #-} 6 | {-# language UndecidableInstances #-} 7 | {-# language GeneralizedNewtypeDeriving #-} 8 | 9 | module Algebra.Zero 10 | ( SemigroupWithZero(..) 11 | , WithZero(Zero,NonZero,WithZero,runWithZero) 12 | ) where 13 | 14 | import Control.Applicative 15 | import Control.Monad 16 | import Control.Monad.Zip 17 | import Data.Data hiding (Prefix) 18 | import Data.Semigroup 19 | import Data.String 20 | import GHC.Generics hiding (Prefix, prec) 21 | import Prelude 22 | import Text.Read 23 | 24 | -- | @ 25 | -- zero <> a = zero = a <> zero 26 | -- @ 27 | class Semigroup a => SemigroupWithZero a where 28 | zero :: a 29 | 30 | instance SemigroupWithZero All where 31 | zero = All False 32 | 33 | instance SemigroupWithZero Any where 34 | zero = Any True 35 | 36 | instance SemigroupWithZero a => SemigroupWithZero (Dual a) where 37 | zero = Dual zero 38 | 39 | instance Num a => SemigroupWithZero (Product a) where 40 | zero = Product 0 41 | 42 | instance (Ord a, Bounded a) => SemigroupWithZero (Max a) where 43 | zero = Max maxBound 44 | 45 | instance (Ord a, Bounded a) => SemigroupWithZero (Min a) where 46 | zero = Min minBound 47 | 48 | -- | pushout 49 | class (SemigroupWithZero a, Monoid a) => MonoidWithZero a 50 | instance (SemigroupWithZero a, Monoid a) => MonoidWithZero a 51 | 52 | -- adjoin a zero element to a semigroup 53 | newtype WithZero a = WithZero { runWithZero :: Maybe a } 54 | deriving (Eq,Ord,Data,Generic,Generic1,Functor,Foldable,Traversable,Applicative,Alternative,Monad,MonadPlus,MonadZip) 55 | 56 | {-# complete Zero, NonZero #-} 57 | 58 | pattern Zero :: WithZero a 59 | pattern Zero = WithZero Nothing 60 | 61 | pattern NonZero :: a -> WithZero a 62 | pattern NonZero a = WithZero (Just a) 63 | 64 | instance Show a => Show (WithZero a) where 65 | showsPrec d (NonZero a) = showParen (d > 10) $ showString "NonZero " . showsPrec 11 a 66 | showsPrec _ _Zero = showString "Zero" 67 | 68 | instance Read a => Read (WithZero a) where 69 | readPrec = parens $ (prec 10 $ do Ident "Zero" <- lexP; return Zero) 70 | +++ (prec 10 $ do Ident "NonZero" <- lexP; NonZero <$> step readPrec) 71 | readListPrec = readListPrecDefault 72 | 73 | instance Semigroup a => Semigroup (WithZero a) where 74 | (<>) = liftA2 (<>) 75 | 76 | instance Semigroup a => SemigroupWithZero (WithZero a) where 77 | zero = empty 78 | 79 | instance Monoid a => Monoid (WithZero a) where 80 | mempty = empty 81 | mappend = liftA2 mappend 82 | 83 | instance IsString a => IsString (WithZero a) where 84 | fromString = NonZero . fromString 85 | -------------------------------------------------------------------------------- /src/common/Relative/Delta/Type.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveGeneric #-} 2 | {-# language DeriveDataTypeable #-} 3 | {-# language GeneralizedNewtypeDeriving #-} 4 | {-# language MultiParamTypeClasses #-} 5 | {-# language TypeFamilies #-} 6 | {-# language FlexibleContexts #-} 7 | {-# language UndecidableInstances #-} 8 | 9 | --------------------------------------------------------------------------------- 10 | -- | 11 | -- Copyright : (c) Edward Kmett 2017-2018 12 | -- License : BSD-2-Clause OR Apache-2.0 13 | -- Maintainer: Edward Kmett 14 | -- Stability : experimental 15 | -- Portability: non-portable 16 | -- 17 | -- Stuff we an measure in UTF-16 code units 18 | --------------------------------------------------------------------------------- 19 | 20 | module Relative.Delta.Type 21 | ( Delta(..) 22 | ) where 23 | 24 | import Data.Data 25 | import Data.Default 26 | import Data.Hashable 27 | import Data.Semigroup 28 | import GHC.Generics 29 | import Text.Read 30 | import Prelude 31 | 32 | -- | A count of UTF-16 code-units. 33 | -- 34 | -- This forms an (obvious) Abelian group unlike 35 | -- the merely monoidal pairs of line and column. 36 | -- 37 | -- It is also very compact fitting in a single 'Int'. 38 | newtype Delta = Delta Int 39 | deriving (Eq, Ord, Data, Generic, Num) 40 | 41 | instance Show Delta where 42 | showsPrec d (Delta n) = showsPrec d n 43 | 44 | instance Read Delta where 45 | readPrec = Delta <$> readPrec 46 | 47 | instance Hashable Delta 48 | 49 | instance Default Delta where 50 | def = Delta def 51 | 52 | instance Semigroup Delta where 53 | (<>) = (+) 54 | 55 | instance Monoid Delta where 56 | mempty = 0 57 | mappend = (+) 58 | -------------------------------------------------------------------------------- /src/common/Syntax/Alex.hs: -------------------------------------------------------------------------------- 1 | {-# language BangPatterns #-} 2 | {-# language TypeFamilies #-} 3 | {-# language DeriveGeneric #-} 4 | {-# language DeriveDataTypeable #-} 5 | 6 | --------------------------------------------------------------------------------- 7 | -- | 8 | -- Copyright : (c) Edward Kmett 2017-2018 9 | -- License : BSD-2-Clause OR Apache-2.0 10 | -- Maintainer: Edward Kmett 11 | -- Stability : experimental 12 | -- Portability: non-portable 13 | -- 14 | -- A simple input adapter that allows @alex@ to work with 'Text' 15 | --------------------------------------------------------------------------------- 16 | 17 | module Syntax.Alex 18 | ( AlexInput(..) 19 | , AlexInputState(..) 20 | , alexGetByte 21 | ) where 22 | 23 | import Data.Bits 24 | import Data.Data 25 | import Data.Hashable 26 | import Data.String 27 | import Data.Text 28 | import Data.Text.Unsafe as Text 29 | import Data.Word (Word8) 30 | import GHC.Generics 31 | 32 | import Syntax.FromText 33 | 34 | -- $setup 35 | -- >>> :set -XOverloadedStrings -XOverloadedLists 36 | -- >>> import Data.List as List (unfoldr) 37 | 38 | data AlexInputState 39 | = S0 | S1 | S2 | S3 40 | deriving (Eq, Ord, Show, Read, Data, Generic) 41 | 42 | instance Hashable AlexInputState 43 | 44 | -- | 45 | -- Invariants: 46 | -- 47 | -- @ 48 | -- 'delta' >= 0 49 | -- @ 50 | data AlexInput = AlexInput 51 | { alexInputState :: !AlexInputState 52 | , alexInputPrevChar :: {-# unpack #-} !Char 53 | , alexInputDelta :: {-# unpack #-} !Int 54 | , alexInputText :: {-# unpack #-} !Text 55 | } deriving (Eq, Ord, Show, Read, Data, Generic) 56 | 57 | instance Hashable AlexInput 58 | 59 | instance IsString AlexInput where 60 | fromString = AlexInput S0 '\n' 0 . fromString 61 | 62 | instance FromText AlexInput where 63 | fromText = AlexInput S0 '\n' 0 64 | {-# inline conlike fromText #-} 65 | 66 | ok :: a -> b -> Maybe (a,b) 67 | ok !a !b = Just (a,b) 68 | 69 | -- | 70 | -- >>> Prelude.take 20 $ List.unfoldr alexGetByte "hello world" 71 | -- [104,101,108,108,111,32,119,111,114,108,100] 72 | alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) 73 | alexGetByte (AlexInput !s !c !d !t) = case s of 74 | S3 | i <- fromEnum c -> ok (fromIntegral $ 0x80 + unsafeShiftR i 12 .&. 0x3f) (AlexInput S2 c (d+1) t) 75 | S2 | i <- fromEnum c -> ok (fromIntegral $ 0x80 + unsafeShiftR i 6 .&. 0x3f) (AlexInput S1 c (d+1) t) 76 | S1 | i <- fromEnum c -> ok (fromIntegral $ 0x80 + i .&. 0x3f) (AlexInput S0 c (d+1) t) 77 | S0 | d < Text.lengthWord16 t -> case Text.iter t d of 78 | Text.Iter c' d' 79 | | i' <= 0x7f -> ok (fromIntegral i') (AlexInput S0 c' (d+d') t) 80 | | i' <= 0x7ff -> ok (fromIntegral $ 0xc0 + unsafeShiftR i' 6) (AlexInput S1 c' (d+d') t) 81 | | i' <= 0xffff -> ok (fromIntegral $ 0xe0 + unsafeShiftR i' 12) (AlexInput S2 c' (d+d') t) 82 | | otherwise -> ok (fromIntegral $ 0xf0 + unsafeShiftR i' 18) (AlexInput S3 c' (d+d') t) 83 | where i' = fromEnum c' 84 | | otherwise -> Nothing 85 | -------------------------------------------------------------------------------- /src/common/Syntax/FromText.hs: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------------------------- 2 | -- | 3 | -- Copyright : (c) Edward Kmett 2017-2018 4 | -- License : BSD-2-Clause OR Apache-2.0 5 | -- Maintainer: Edward Kmett 6 | -- Stability : experimental 7 | -- Portability: non-portable 8 | -- 9 | --------------------------------------------------------------------------------- 10 | 11 | module Syntax.FromText 12 | ( FromText(..) 13 | ) where 14 | 15 | import Data.Text 16 | 17 | class FromText a where 18 | fromText :: Text -> a 19 | 20 | instance FromText Text where 21 | fromText = id 22 | -------------------------------------------------------------------------------- /src/common/Syntax/Name.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveDataTypeable #-} 2 | {-# language DeriveGeneric #-} 3 | {-# language TemplateHaskell #-} 4 | {-# language PatternSynonyms #-} 5 | {-# language MultiParamTypeClasses #-} 6 | {-# language FunctionalDependencies #-} 7 | {-# language OverloadedStrings #-} 8 | 9 | --------------------------------------------------------------------------------- 10 | -- | 11 | -- Copyright : (c) Edward Kmett 2017-2018 12 | -- License : BSD-2-Clause OR Apache-2.0 13 | -- Maintainer: Edward Kmett 14 | -- Stability : experimental 15 | -- Portability: non-portable 16 | -- 17 | --------------------------------------------------------------------------------- 18 | 19 | module Syntax.Name 20 | ( Name(Qualified, Unqualified, QVarId, QConId, QVarOp, QConOp, VarId, ConId, VarOp, ConOp) 21 | , HasOperator(..) 22 | , HasConstructor(..) 23 | , HasIdent(..) 24 | , HasQualifier(..) 25 | ) where 26 | 27 | import Control.Lens 28 | import Data.Data 29 | import Data.Text 30 | import GHC.Generics hiding (prec) 31 | import Text.Read 32 | 33 | data Name 34 | = Qualified { _operator :: !Bool, _constructor :: !Bool, _qualifier :: !Text, _ident :: !Text } 35 | | Unqualified { _operator :: !Bool, _constructor :: !Bool, _ident :: !Text } 36 | deriving (Eq,Ord,Data,Generic) 37 | {-# complete QConId, QVarId, QConOp, QVarOp, ConId, VarId, ConOp, VarOp #-} 38 | 39 | pattern QVarId :: Text -> Text -> Name 40 | pattern QVarId q i = Qualified True False q i 41 | 42 | pattern QConId :: Text -> Text -> Name 43 | pattern QConId q i = Qualified True True q i 44 | 45 | pattern QVarOp :: Text -> Text -> Name 46 | pattern QVarOp q i = Qualified False False q i 47 | 48 | pattern QConOp :: Text -> Text -> Name 49 | pattern QConOp q i = Qualified False True q i 50 | 51 | pattern VarId :: Text -> Name 52 | pattern VarId i = Unqualified True False i 53 | 54 | pattern ConId :: Text -> Name 55 | pattern ConId i = Unqualified True True i 56 | 57 | pattern VarOp :: Text -> Name 58 | pattern VarOp i = Unqualified False False i 59 | 60 | pattern ConOp :: Text -> Name 61 | pattern ConOp i = Unqualified False True i 62 | 63 | instance Show Name where 64 | showsPrec d (QVarId q n) = showParen (d > 10) $ showString "QVarId " . showsPrec 11 q . showChar ' ' . showsPrec 11 n 65 | showsPrec d (QConId q n) = showParen (d > 10) $ showString "QConId " . showsPrec 11 q . showChar ' ' . showsPrec 11 n 66 | showsPrec d (QVarOp q n) = showParen (d > 10) $ showString "QVarOp " . showsPrec 11 q . showChar ' ' . showsPrec 11 n 67 | showsPrec d (QConOp q n) = showParen (d > 10) $ showString "QConOp " . showsPrec 11 q . showChar ' ' . showsPrec 11 n 68 | showsPrec d (VarId n) = showParen (d > 10) $ showString "VarId " . showsPrec 11 n 69 | showsPrec d (ConId n) = showParen (d > 10) $ showString "ConId " . showsPrec 11 n 70 | showsPrec d (VarOp n) = showParen (d > 10) $ showString "VarOp " . showsPrec 11 n 71 | showsPrec d (ConOp n) = showParen (d > 10) $ showString "ConOp " . showsPrec 11 n 72 | 73 | instance Read Name where 74 | readPrec = parens 75 | $ prec 10 (do Ident "QVarId" <- lexP; QVarId <$> step readPrec <*> step readPrec) 76 | +++ prec 10 (do Ident "QConId" <- lexP; QConId <$> step readPrec <*> step readPrec) 77 | +++ prec 10 (do Ident "QVarOp" <- lexP; QVarOp <$> step readPrec <*> step readPrec) 78 | +++ prec 10 (do Ident "QConOp" <- lexP; QConOp <$> step readPrec <*> step readPrec) 79 | +++ prec 10 (do Ident "VarId" <- lexP; VarId <$> step readPrec) 80 | +++ prec 10 (do Ident "ConId" <- lexP; ConId <$> step readPrec) 81 | +++ prec 10 (do Ident "VarOp" <- lexP; VarOp <$> step readPrec) 82 | +++ prec 10 (do Ident "ConOp" <- lexP; ConOp <$> step readPrec) 83 | 84 | makeFieldsNoPrefix ''Name 85 | -------------------------------------------------------------------------------- /src/common/Syntax/Prefix.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveDataTypeable #-} 2 | {-# language DeriveGeneric #-} 3 | {-# language OverloadedStrings #-} 4 | 5 | --------------------------------------------------------------------------------- 6 | -- | 7 | -- Copyright : (c) Edward Kmett 2017-2018 8 | -- License : BSD-2-Clause OR Apache-2.0 9 | -- Maintainer: Edward Kmett 10 | -- Stability : experimental 11 | -- Portability: non-portable 12 | -- 13 | --------------------------------------------------------------------------------- 14 | 15 | module Syntax.Prefix 16 | ( Prefix(..) 17 | , joinAndCompare 18 | , HasPrefix(..) 19 | ) where 20 | 21 | import Data.Char (isSpace) 22 | import Data.Data hiding (Prefix) 23 | import Data.Semigroup 24 | import Data.String 25 | import Data.Text as Text 26 | import GHC.Generics hiding (Prefix) 27 | import Prelude 28 | 29 | import Algebra.Zero 30 | import Syntax.FromText 31 | 32 | -- | line prefixes form a semigroup with a zero 33 | newtype Prefix = Prefix Text deriving (Eq,Show,Generic,Data) 34 | 35 | joinAndCompare :: Prefix -> Prefix -> Either Prefix Ordering 36 | joinAndCompare (Prefix xs) (Prefix ys) = case commonPrefixes xs ys of 37 | Just (c, l, r) -> cmp c l r 38 | Nothing -> cmp "" xs ys 39 | where 40 | cmp _ "" "" = Right EQ 41 | cmp _ "" _ = Right LT 42 | cmp _ _ "" = Right GT 43 | cmp c _ _ = Left (Prefix c) 44 | 45 | instance Semigroup Prefix where 46 | Prefix xs <> Prefix ys 47 | = Prefix $ case commonPrefixes xs ys of 48 | Just (zs, _, _) -> zs 49 | Nothing -> "" 50 | 51 | instance SemigroupWithZero Prefix where 52 | zero = Prefix "" 53 | 54 | instance FromText Prefix where 55 | fromText = Prefix . Text.takeWhile isSpace 56 | 57 | instance IsString Prefix where 58 | fromString = Prefix . pack . Prelude.takeWhile isSpace 59 | 60 | class HasPrefix t where 61 | prefix :: t -> Prefix 62 | 63 | instance HasPrefix Prefix where 64 | prefix = id 65 | -------------------------------------------------------------------------------- /src/common/Syntax/Sharing.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveTraversable, DeriveDataTypeable, DeriveGeneric #-} 2 | module Syntax.Sharing 3 | ( Sharing(..), sharing, changed 4 | ) where 5 | 6 | import Data.Bits 7 | import Data.Data 8 | import GHC.Generics 9 | 10 | data Sharing a = Sharing {-# UNPACK #-} !Int a 11 | deriving (Foldable, Traversable, Generic, Generic1, Data, Eq, Ord, Show, Read) 12 | 13 | instance Functor Sharing where 14 | fmap f (Sharing m a) = Sharing m (f a) 15 | a <$ Sharing m _ = Sharing m a 16 | 17 | instance Applicative Sharing where 18 | pure = Sharing 0 19 | Sharing m f <*> Sharing n a = Sharing (m .|. n) (f a) 20 | Sharing m x <* Sharing n _ = Sharing (m .|. n) x 21 | Sharing m _ *> Sharing n x = Sharing (m .|. n) x 22 | 23 | instance Monad Sharing where 24 | Sharing 0 a >>= f = f a 25 | Sharing _ a >>= f = case f a of 26 | Sharing _ b -> Sharing 1 b 27 | Sharing m _ >> Sharing n a = Sharing (m .|. n) a 28 | 29 | changed :: a -> Sharing a 30 | changed = Sharing 1 31 | 32 | sharing :: a -> Sharing a -> a 33 | sharing z (Sharing 0 _) = z 34 | sharing _ (Sharing _ y) = y 35 | -------------------------------------------------------------------------------- /src/common/Util/BitQueue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Copyright : (c) David Feuer 2016 7 | -- License : BSD-style 8 | -- Maintainer : ekmett@gmail.com 9 | -- Portability : non-portable 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | module Util.BitQueue 14 | ( BitQueue 15 | , BitQueueB 16 | , emptyQB 17 | , snocQB 18 | , buildQ 19 | , unconsQ 20 | , toListQ 21 | ) where 22 | 23 | import Util.Bits (shiftLL, shiftRL, wordSize) 24 | import Data.Bits ((.|.), (.&.), testBit, countTrailingZeros) 25 | 26 | -- A bit queue builder. We represent a double word using two words 27 | -- because we don't currently have access to proper double words. 28 | data BitQueueB = BQB {-# UNPACK #-} !Word 29 | {-# UNPACK #-} !Word 30 | 31 | newtype BitQueue = BQ BitQueueB deriving Show 32 | 33 | -- Intended for debugging. 34 | instance Show BitQueueB where 35 | show (BQB hi lo) = "BQ"++ 36 | show (map (testBit hi) [(wordSize - 1),(wordSize - 2)..0] 37 | ++ map (testBit lo) [(wordSize - 1),(wordSize - 2)..0]) 38 | 39 | -- | Create an empty bit queue builder. This is represented as a single guard 40 | -- bit in the most significant position. 41 | emptyQB :: BitQueueB 42 | emptyQB = BQB (shiftLL 1 (wordSize - 1)) 0 43 | {-# INLINE emptyQB #-} 44 | 45 | -- Shift the double word to the right by one bit. 46 | shiftQBR1 :: BitQueueB -> BitQueueB 47 | shiftQBR1 (BQB hi lo) = BQB hi' lo' where 48 | lo' = shiftRL lo 1 .|. shiftLL hi (wordSize - 1) 49 | hi' = shiftRL hi 1 50 | {-# INLINE shiftQBR1 #-} 51 | 52 | -- | Enqueue a bit. This works by shifting the queue right one bit, 53 | -- then setting the most significant bit as requested. 54 | {-# INLINE snocQB #-} 55 | snocQB :: BitQueueB -> Bool -> BitQueueB 56 | snocQB bq b = case shiftQBR1 bq of 57 | BQB hi lo -> BQB (hi .|. shiftLL (fromIntegral (fromEnum b)) (wordSize - 1)) lo 58 | 59 | -- | Convert a bit queue builder to a bit queue. This shifts in a new 60 | -- guard bit on the left, and shifts right until the old guard bit falls 61 | -- off. 62 | {-# INLINE buildQ #-} 63 | buildQ :: BitQueueB -> BitQueue 64 | buildQ (BQB hi 0) = BQ (BQB 0 lo') where 65 | zeros = countTrailingZeros hi 66 | lo' = shiftRL (shiftRL hi 1 .|. shiftLL 1 (wordSize - 1)) zeros 67 | buildQ (BQB hi lo) = BQ (BQB hi' lo') where 68 | zeros = countTrailingZeros lo 69 | lo1 = shiftRL lo 1 .|. shiftLL hi (wordSize - 1) 70 | hi1 = shiftRL hi 1 .|. shiftLL 1 (wordSize - 1) 71 | lo' = shiftRL lo1 zeros .|. shiftLL hi1 (wordSize - zeros) 72 | hi' = shiftRL hi1 zeros 73 | 74 | -- Test if the queue is empty, which occurs when theres 75 | -- nothing left but a guard bit in the least significant 76 | -- place. 77 | nullQ :: BitQueue -> Bool 78 | nullQ (BQ (BQB 0 1)) = True 79 | nullQ _ = False 80 | {-# INLINE nullQ #-} 81 | 82 | -- | Dequeue an element, or discover the queue is empty. 83 | unconsQ :: BitQueue -> Maybe (Bool, BitQueue) 84 | unconsQ q | nullQ q = Nothing 85 | unconsQ (BQ bq@(BQB _ lo)) = Just (hd, BQ tl) where 86 | !hd = (lo .&. 1) /= 0 87 | !tl = shiftQBR1 bq 88 | {-# INLINE unconsQ #-} 89 | 90 | -- | Convert a bit queue to a list of bits by unconsing. 91 | -- This is used to test that the queue functions properly. 92 | toListQ :: BitQueue -> [Bool] 93 | toListQ bq = case unconsQ bq of 94 | Nothing -> [] 95 | Just (hd, tl) -> hd : toListQ tl 96 | -------------------------------------------------------------------------------- /src/common/Util/Bits.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE MagicHash #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Copyright : (c) Edward Kmett 2017-2018 (c) Clark Gaebel 2012, (c) Johan Tibel 2012 7 | -- License : BSD-style 8 | -- Maintainer : ekmett@gmail.com 9 | -- Portability : non-portable 10 | ----------------------------------------------------------------------------- 11 | 12 | module Util.Bits 13 | ( highestBitMask 14 | , shiftLL 15 | , shiftRL 16 | , wordSize 17 | ) where 18 | 19 | import Data.Bits ((.|.), xor, finiteBitSize) 20 | import GHC.Exts (Word(..), Int(..)) 21 | import GHC.Prim (uncheckedShiftL#, uncheckedShiftRL#) 22 | 23 | -- The highestBitMask implementation is based on 24 | -- http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2 25 | -- which has been put in the public domain. 26 | 27 | -- | Return a word where only the highest bit is set. 28 | highestBitMask :: Word -> Word 29 | highestBitMask x1 = x7 `xor` (x7 `shiftRL` 1) where 30 | x2 = x1 .|. shiftRL x1 1 31 | x3 = x2 .|. shiftRL x2 2 32 | x4 = x3 .|. shiftRL x3 4 33 | x5 = x4 .|. shiftRL x4 8 34 | x6 = x5 .|. shiftRL x5 16 35 | x7 = x6 .|. shiftRL x6 32 36 | {-# inline highestBitMask #-} 37 | 38 | -- Right and left logical shifts. 39 | shiftRL, shiftLL :: Word -> Int -> Word 40 | shiftRL (W# x) (I# i) = W# (uncheckedShiftRL# x i) 41 | shiftLL (W# x) (I# i) = W# (uncheckedShiftL# x i) 42 | {-# inline CONLIKE shiftRL #-} 43 | {-# inline CONLIKE shiftLL #-} 44 | 45 | wordSize :: Int 46 | wordSize = finiteBitSize (0 :: Word) 47 | {-# inline wordSize #-} 48 | -------------------------------------------------------------------------------- /src/console/Console.hs: -------------------------------------------------------------------------------- 1 | module Console (console) where 2 | 3 | import Control.Lens 4 | import Control.Monad.IO.Class (liftIO) 5 | import Control.Monad (when, unless) 6 | import Data.Char 7 | import System.Console.Haskeline 8 | 9 | import Console.Completion 10 | import Console.Options 11 | import Console.Unicode 12 | import Version 13 | 14 | -- returns whether to carry on 15 | executeCommand :: String -> InputT IO Bool 16 | executeCommand "q" = return False 17 | executeCommand _ = return True 18 | 19 | heading :: String 20 | heading = "Coda " ++ version 21 | 22 | console :: ConsoleOptions -> IO () 23 | console opts = withUnicode $ do 24 | unless (opts^.consoleOptionsNoHeading) $ putStrLn heading 25 | runInputT settings loop 26 | 27 | loop :: InputT IO () 28 | loop = do 29 | minput <- getInputLine "λ> " 30 | case Prelude.dropWhile isSpace <$> minput of 31 | Nothing -> return () 32 | Just "quit" -> return () 33 | Just (':':cmd) -> do 34 | b <- executeCommand cmd 35 | when b loop 36 | Just "" -> loop 37 | Just input -> do 38 | liftIO $ putStrLn input 39 | loop 40 | -------------------------------------------------------------------------------- /src/console/Console/Command.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ExtendedDefaultRules #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 10 | 11 | -------------------------------------------------------------------- 12 | -- | 13 | -- Copyright : (c) Edward Kmett 2017-2018, (c) Edward Kmett and Dan Doel 2012-2013 14 | -- License : BSD-2-Clause OR Apache-2.0 15 | -- Maintainer: Edward Kmett 16 | -- Stability : experimental 17 | -- Portability: non-portable 18 | -- 19 | -------------------------------------------------------------------- 20 | 21 | module Console.Command 22 | ( Command(..) 23 | , HasCommand(..) 24 | , commands 25 | , executeCommand 26 | ) where 27 | 28 | import Control.Lens as Lens 29 | import Control.Monad.IO.Class 30 | import Data.Char 31 | import Data.List as List 32 | import Data.List.Split (splitOn) 33 | import Data.Monoid 34 | import Data.String 35 | import Data.Text (pack) 36 | import System.Console.Haskeline 37 | import System.Exit 38 | -- import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) 39 | import Data.Text.Prettyprint.Doc 40 | -- import Data.Text.Prettyprint.Doc.Render.Text as RenderText 41 | import Data.Text.Prettyprint.Doc.Render.Terminal as RenderTerminal 42 | import Prelude hiding (lex) 43 | 44 | import Console.Pretty 45 | import Syntax.Dyck 46 | import Syntax.Lexer 47 | import Version 48 | 49 | ------------------------------------------------------------------------------ 50 | -- Command 51 | ------------------------------------------------------------------------------ 52 | 53 | data Command = Command 54 | { _cmdName :: String 55 | , _alts :: [String] 56 | , _arg :: Maybe String 57 | , _tabbed :: Maybe (CompletionFunc IO) 58 | , _desc :: String 59 | , _body :: FancyOptions -> [String] -> String -> IO () 60 | } 61 | 62 | makeClassy ''Command 63 | 64 | cmd :: String -> Command 65 | cmd nm = Command nm [] Nothing Nothing "" $ \_ _ _ -> return () 66 | 67 | getCommand :: String -> Maybe (Command, [String], String) 68 | getCommand zs = commands ^? 69 | folded. 70 | filtered (\c -> isPrefixOf xs (c^.cmdName) 71 | || anyOf (alts.folded) (isPrefixOf xs) c). 72 | to (,as,ys') 73 | where 74 | (cs, ys) = break isSpace zs 75 | xs:as = splitOn "+" cs 76 | ys' = reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace ys 77 | 78 | executeCommand :: FancyOptions -> String -> IO () 79 | executeCommand fancy txt = case getCommand txt of 80 | Just (c,args,input) -> view body c fancy args input 81 | Nothing -> do 82 | putFancy fancy $ annotate (color Red) "Unknown command" <+> annotate bold (pretty (cons ':' txt)) 83 | putFancy fancy $ "Use" <+> annotate bold (pretty ":?") <+> "for help." 84 | 85 | showHelp :: FancyOptions -> [String] -> String -> IO () 86 | showHelp fancy _ _ = putFancy fancy $ vsep (format <$> commands) where 87 | format c = fill 18 (withArg c) <+> hang 18 (fillSep (pretty <$> words (c^.desc))) 88 | withArg c = case c^.arg of 89 | Nothing -> annotate bold (pretty ':' <> pretty (c^.cmdName)) 90 | Just a -> annotate bold (pretty ':' <> pretty (c^.cmdName)) <+> angles (pretty a) 91 | 92 | commands :: [Command] 93 | commands = 94 | [ cmd "help" & desc .~ "show help" & alts .~ ["?"] & body .~ showHelp 95 | , cmd "quit" & desc .~ "quit" & body .~ \_ _ _ -> liftIO exitSuccess 96 | , cmd "dyck" & desc .~ "debug dyck language tokenization" & body .~ \_ _ input -> 97 | liftIO $ print (lex (pack input) :: Dyck) 98 | , cmd "version" 99 | & desc .~ "show the compiler version number" 100 | & body .~ \_ _ _ -> liftIO $ putStrLn version 101 | ] 102 | -------------------------------------------------------------------------------- /src/console/Console/Completion.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- | 3 | -- Copyright : (c) Edward Kmett 2017-2018, (c) Edward Kmett and Dan Doel 2012-2013 4 | -- License : BSD-2-Clause OR Apache-2.0 5 | -- Maintainer: Edward Kmett 6 | -- Stability : experimental 7 | -- Portability: non-portable 8 | -- 9 | -------------------------------------------------------------------- 10 | 11 | module Console.Completion 12 | ( settings 13 | ) where 14 | 15 | import Control.Lens 16 | import Data.Char 17 | import Data.List 18 | import Data.Set as Set 19 | import Data.Set.Lens 20 | import System.Console.Haskeline 21 | 22 | import Syntax.Token 23 | import Console.Command 24 | 25 | startingKeywordSet, keywordSet :: Set String 26 | startingKeywordSet = setOf folded startingKeywords 27 | <> setOf (folded.cmdName.to (':':)) commands 28 | keywordSet = setOf folded keywords 29 | 30 | loading :: String -> Bool 31 | loading zs = isPrefixOf ":l" xs && isPrefixOf xs ":load" 32 | where xs = takeWhile (not . isSpace) $ dropWhile isSpace zs 33 | 34 | completed :: (String,String) -> IO (String, [Completion]) 35 | completed (ls, rs) 36 | | ' ' `notElem` ls = completeWith startingKeywordSet (ls, rs) 37 | | loading rls = completeFilename (ls, rs) -- todo upgrade this to use more general per-command parser 38 | | otherwise = completeWith keywordSet (ls, rs) 39 | where rls = reverse ls 40 | 41 | completeWith :: Set String -> CompletionFunc IO 42 | completeWith kws = completeWord Nothing " ,()[]{}" $ \s -> do 43 | -- strs <- use consoleIds 44 | let strs = mempty 45 | return $ (strs <> kws)^..folded.filtered (s `isPrefixOf`).to (\o -> Completion o o True) 46 | 47 | -- | Haskeline settings supporting autocomplete and persistent history 48 | settings :: Settings IO 49 | settings = setComplete completed defaultSettings 50 | { historyFile = Just ".coda_history" 51 | } 52 | -------------------------------------------------------------------------------- /src/console/Console/Options.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveGeneric, DeriveAnyClass, TemplateHaskell #-} 2 | module Console.Options where 3 | 4 | import Control.Lens 5 | import Data.Default.Class 6 | import GHC.Generics 7 | import Options.Applicative as Options 8 | 9 | import Console.Pretty 10 | 11 | data ConsoleOptions = ConsoleOptions 12 | { _consoleFancyOptions :: FancyOptions 13 | , _consoleOptionsNoHeading :: Bool 14 | } 15 | deriving (Show,Generic) 16 | 17 | instance Default ConsoleOptions where 18 | def = ConsoleOptions def False 19 | 20 | parseConsoleOptions :: Options.Parser ConsoleOptions 21 | parseConsoleOptions = ConsoleOptions <$> parseFancyOptions <*> pure False 22 | 23 | makeClassy ''ConsoleOptions 24 | 25 | instance HasFancyOptions ConsoleOptions where 26 | fancyOptions = consoleFancyOptions 27 | -------------------------------------------------------------------------------- /src/console/Console/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# language CPP #-} 2 | {-# language TemplateHaskell #-} 3 | {-# language DefaultSignatures #-} 4 | 5 | module Console.Pretty 6 | ( 7 | -- * options 8 | FancyOptions(..) 9 | , HasFancyOptions(..) 10 | , parseFancyOptions 11 | -- * pretty printing 12 | , putFancy 13 | , hPutFancy 14 | -- * useful internals 15 | , fcols 16 | ) where 17 | 18 | import Control.Monad.IO.Class 19 | import Control.Lens 20 | import Data.Bool (bool) 21 | import Data.Char (toLower) 22 | import Data.Default.Class 23 | import Data.Maybe (fromMaybe) 24 | import Data.String 25 | import Data.Text.Prettyprint.Doc 26 | import Data.Text.Prettyprint.Doc.Render.Text as RenderText 27 | import Data.Text.Prettyprint.Doc.Render.Terminal as RenderTerminal 28 | import GHC.IO.Handle 29 | import Options.Applicative as Options 30 | import System.Console.ANSI (hSupportsANSI) 31 | import System.IO (Handle, stdout) 32 | #ifdef MIN_VERSION_terminfo 33 | import System.Console.Terminfo.Base (setupTermFromEnv, getCapability) 34 | import System.Console.Terminfo.Cursor (termColumns) 35 | #endif 36 | import Text.Read (readMaybe) 37 | 38 | instance IsString str => MonadFail (Either str) where 39 | fail = Left . fromString 40 | 41 | data FancyOptions 42 | = FancyOptions 43 | { _fancyColor :: Maybe Bool 44 | , _fancyWidth :: Maybe Int 45 | } 46 | deriving Show 47 | 48 | makeClassy ''FancyOptions 49 | 50 | instance Default FancyOptions where 51 | def = FancyOptions Nothing Nothing 52 | 53 | parseFancyOptions :: Options.Parser FancyOptions 54 | parseFancyOptions = FancyOptions 55 | <$> option colorOpt colorPrefs 56 | <*> option widthOpt widthPrefs 57 | where 58 | colorPrefs 59 | = long "ansi-color" 60 | <> short 'c' 61 | <> metavar "SETTING" 62 | <> value Nothing 63 | <> help "Emit ANSI: 'always', 'never' or 'auto'" 64 | colorOpt = eitherReader $ \s -> case map toLower s of 65 | "always" -> pure $ Just True 66 | "never" -> pure $ Just False 67 | "auto" -> pure Nothing 68 | _ -> fail "Expected --ansi-color=always|never|auto" 69 | widthOpt = eitherReader $ \s -> case map toLower s of 70 | "auto" -> pure Nothing 71 | _ -> case readMaybe s of 72 | Just a -> Right (Just a) 73 | Nothing -> fail "Expected number or 'auto'" 74 | widthPrefs 75 | = long "console-width" 76 | <> short 'w' 77 | <> metavar "WIDTH" 78 | <> value Nothing 79 | <> help "Console width in characters or 'auto'" 80 | 81 | defaultCols :: Int 82 | defaultCols = 78 83 | 84 | fansi :: FancyOptions -> Handle -> IO Bool 85 | fansi opts h = maybe (hSupportsANSI h) pure (_fancyColor opts) 86 | 87 | fcols :: FancyOptions -> Handle -> IO Int 88 | fcols opts h = maybe query pure (_fancyWidth opts) where 89 | #ifdef MIN_VERSION_terminfo 90 | query = do 91 | tty <- hIsTerminalDevice h 92 | if tty then do 93 | term <- setupTermFromEnv 94 | return $ fromMaybe defaultCols $ getCapability term termColumns 95 | else return defaultCols 96 | #else 97 | query = return defaultCols 98 | #endif 99 | 100 | flayoutOptions :: FancyOptions -> Handle -> IO LayoutOptions 101 | flayoutOptions opts h = do 102 | cols <- fcols opts h 103 | return defaultLayoutOptions { layoutPageWidth = AvailablePerLine cols 1.0 } 104 | 105 | putFancy :: MonadIO m => FancyOptions -> Doc AnsiStyle -> m () 106 | putFancy opts = hPutFancy opts stdout 107 | 108 | hPutFancy :: MonadIO m => FancyOptions -> Handle -> Doc AnsiStyle -> m () 109 | hPutFancy opts h doc = liftIO $ do 110 | render <- bool RenderText.renderIO RenderTerminal.renderIO <$> fansi opts h 111 | layout <- flayoutOptions opts h 112 | render h $ layoutPretty layout doc 113 | -------------------------------------------------------------------------------- /src/console/Console/Unicode.hsc: -------------------------------------------------------------------------------- 1 | {-# language CPP #-} 2 | {-# language ForeignFunctionInterface #-} 3 | {-# options_ghc -Wno-redundant-constraints #-} 4 | 5 | -------------------------------------------------------------------- 6 | -- | 7 | -- Copyright : (c) Edward Kmett 2017-2018, (c) Edward Kmett and Dan Doel 2012-2013 8 | -- License : BSD2 or Apache 2.0 9 | -- Maintainer: Edward Kmett 10 | -- Stability : experimental 11 | -- Portability: non-portable 12 | -- 13 | -------------------------------------------------------------------- 14 | 15 | module Console.Unicode 16 | ( withUnicode 17 | ) where 18 | 19 | import Control.Monad.Catch 20 | 21 | ##ifdef mingw32_HOST_ARCH 22 | ##ifdef i386_HOST_ARCH 23 | ##define USE_CP 24 | import Control.Monad.IO.Class 25 | import System.IO 26 | import Foreign.C.Types 27 | foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool 28 | foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt 29 | ##elif defined(x86_64_HOST_ARCH) 30 | ##define USE_CP 31 | import Control.Monad.IO.Class 32 | import System.IO 33 | import Foreign.C.Types 34 | foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool 35 | foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt 36 | ##endif 37 | ##endif 38 | 39 | -- | Run in a modified codepage where we can print UTF-8 values on Windows. 40 | -- 41 | -- You should probably run the top level of your program in this. 42 | withUnicode :: MonadCatch m => m a -> m a 43 | ##ifdef USE_CP 44 | withUnicode m = do 45 | cp <- liftIO c_GetConsoleCP 46 | enc <- liftIO $ hGetEncoding stdout 47 | let setup = liftIO $ c_SetConsoleCP 65001 >> hSetEncoding stdout utf8 48 | cleanup = liftIO $ maybe (return ()) (hSetEncoding stdout) enc >> c_SetConsoleCP cp 49 | finally (setup >> m) cleanup 50 | ##else 51 | withUnicode m = m 52 | ##endif 53 | -------------------------------------------------------------------------------- /src/dyck/Dyck.hs: -------------------------------------------------------------------------------- 1 | {-# language MultiParamTypeClasses #-} 2 | {-# language UndecidableInstances #-} 3 | {-# language FlexibleInstances #-} 4 | {-# language FlexibleContexts #-} 5 | {-# language DeriveGeneric #-} 6 | {-# language TypeFamilies #-} 7 | {-# language LambdaCase #-} 8 | 9 | --------------------------------------------------------------------------------- 10 | -- | 11 | -- Copyright : (c) Edward Kmett 2017-2018 12 | -- License : BSD-2-Clause OR Apache-2.0 13 | -- Maintainer: Edward Kmett 14 | -- Stability : experimental 15 | -- Portability: non-portable 16 | -- 17 | --------------------------------------------------------------------------------- 18 | 19 | module Dyck 20 | ( 21 | -- Dyck language monoid 22 | Dyck(..) 23 | , Opening(..) 24 | , Closing(..) 25 | , LocatedPair 26 | , MismatchError(..) 27 | , token 28 | , layoutToken 29 | , close 30 | , open 31 | , spine 32 | , dyckLayoutMode 33 | , dyckMismatchErrors 34 | , boring 35 | ) where 36 | 37 | 38 | import Control.Comonad 39 | import Control.Exception 40 | import Control.Lens 41 | import Data.Default 42 | import Data.Semigroup 43 | import GHC.Generics 44 | import Prelude 45 | 46 | import Relative.Cat as Cat 47 | import Relative.Class 48 | import Relative.Located 49 | import Rev 50 | 51 | import Token 52 | 53 | -------------------------------------------------------------------------------- 54 | -- Dyck Language 55 | -------------------------------------------------------------------------------- 56 | 57 | type LocatedPair = Located Pair 58 | 59 | data MismatchError = MismatchError {-# unpack #-} !LocatedPair {-# unpack #-} !LocatedPair 60 | deriving (Show, Read, Eq, Ord) 61 | 62 | instance Exception MismatchError 63 | 64 | instance Relative MismatchError where 65 | rel 0 xs = xs 66 | rel d (MismatchError l r) = MismatchError (rel d l) (rel d r) 67 | 68 | data Opening = Opening {-# unpack #-} !LocatedPair !(Cat Token) 69 | deriving (Generic, Show, Eq, Ord, Read) 70 | 71 | data Closing = Closing !(Cat Token) {-# unpack #-} !LocatedPair 72 | deriving (Generic, Show, Eq, Ord, Read) 73 | 74 | -- | @Dyck l ms r s k e@ 75 | -- 76 | -- @k@ indicates if the last token was a layout keyword, and if so can provide a 77 | -- numerical indicator as to which one. 0 means either no it wasn't or that we 78 | -- haven't seen a 79 | data Dyck 80 | = Dyck 81 | !(Cat Closing) 82 | !(Cat Token) 83 | !(Rev Cat Opening) 84 | !(Cat Token) 85 | !LayoutMode 86 | !(Cat MismatchError) -- errors 87 | deriving (Generic, Show, Eq, Ord, Read) 88 | 89 | boring :: Dyck -> Bool 90 | boring = views dyckLayoutMode (def ==) 91 | 92 | dyckLayoutMode :: Lens' Dyck LayoutMode 93 | dyckLayoutMode f (Dyck l ms r s k e) = f k <&> \k' -> Dyck l ms r s k' e 94 | 95 | dyckMismatchErrors :: Lens' Dyck (Cat MismatchError) 96 | dyckMismatchErrors f (Dyck l ms r s k e) = Dyck l ms r s k <$> f e 97 | 98 | instance AsEmpty Dyck where 99 | _Empty = prism (const def) $ \case 100 | Dyck Empty Empty (Rev Empty) Empty _ Empty -> Right () 101 | x -> Left x 102 | 103 | instance Relative Opening where 104 | rel d (Opening p xs) = Opening (rel d p) (rel d xs) 105 | 106 | instance Relative Closing where 107 | rel d (Closing xs q) = Closing (rel d xs) (rel d q) 108 | 109 | instance Relative Dyck where 110 | rel 0 xs = xs 111 | rel d (Dyck l ms r s k e) = Dyck (rel d l) (rel d ms) (rel d r) (rel d s) k (rel d e) 112 | 113 | -- | O(1) 114 | token :: Dyck -> Token -> Dyck 115 | token (Dyck l ms r s _ e) a = Dyck l ms r (snocCat s a) def e 116 | 117 | layoutToken :: Dyck -> LayoutMode -> Token -> Dyck 118 | layoutToken (Dyck l ms r s _ e) i a = Dyck l ms r (snocCat s a) i e 119 | 120 | -- | O(1) 121 | close :: Dyck -> Located Pair -> Dyck 122 | close (Dyck l ms (r' :> Opening dp@(Located lp p) rs) s _ e) dq@(Located lq q) 123 | | p == q = Dyck l ms r' (Cat.singleton $ nested p lp (rs<>s) lq) def e 124 | | otherwise = Dyck l ms r' (Cat.singleton $ mismatch dp dq (rs<>s)) def (snocCat e $! MismatchError dp dq) 125 | close (Dyck l ms _ s _ e) dq = Dyck (snocCat l $ Closing (ms <> s) dq) mempty mempty mempty def e 126 | 127 | -- | O(1) 128 | open :: Dyck -> Located Pair -> Dyck 129 | open (Dyck l m (r' :> Opening dp rs) s _ e) dq = Dyck l m ((r' :> Opening dp (rs<>s)) :> Opening dq mempty) s def e 130 | open (Dyck l m _ s _ e) dp = Dyck l (m<>s) (Rev $ Cat.singleton $ Opening dp mempty) mempty def e 131 | 132 | instance Default Dyck where 133 | def = Dyck def def def def def def 134 | 135 | -- | O(k) in the number of canceled contexts 136 | -- 137 | -- Note: positions are not shifted, so you'll need to use this inside a semi-direct product with Delta. 138 | instance Semigroup Dyck where 139 | m <> Dyck Empty Empty Empty Empty _ Empty = m 140 | Dyck l0 m0 r0 s0 _ e0 <> Dyck l1 m1 r1 s1 k1 e1 = go l0 m0 r0 s0 e0 l1 m1 r1 s1 k1 e1 where 141 | go l2 m2 (r2' :> Opening dp@(Located lp p) xs) s2 e2 (Closing ys dq@(Located lq q) :< l3') m3 r3 s3 k3 e3 142 | | p == q = go l2 m2 r2' (Cat.singleton $ nested p lp (xs<>s2<>ys) lq) e2 l3' m3 r3 s3 k3 e3 143 | | otherwise = go l2 m2 r2' (Cat.singleton $ mismatch dp dq (xs<>s2<>ys)) (snocCat e2 $! MismatchError dp dq) l3' m3 r3 s3 k3 e3 144 | go l2 m2 (r2' :> Opening dp xs) s2 e2 _ m3 r3 s3 k3 e3 = Dyck l2 m2 ((r2' :> Opening dp (xs<>s2<>m3))<>r3) s3 k3 (e2<>e3) 145 | go l2 m2 _ s2 e2 (Closing xs dp :< l3') m3 r3 s3 k3 e3 = Dyck (l2<>(Closing (m2<>s2<>xs) dp :< l3')) m3 r3 s3 k3 (e2<>e3) 146 | go l2 m2 _ s2 e2 _ m3 r3 s3 k3 e3 = Dyck l2 (m2<>s2<>m3) r3 s3 k3 (e2<>e3) 147 | 148 | instance Monoid Dyck where 149 | mempty = Dyck mempty mempty mempty mempty def mempty 150 | mappend = (<>) 151 | {-# inline mappend #-} 152 | 153 | instance RelativeSemigroup Dyck 154 | 155 | instance RelativeMonoid Dyck 156 | 157 | -- convert a dyck language skeleton to a set of tokens (including unmatched closings and openings) 158 | spine :: Dyck -> Cat Token 159 | spine (Dyck l0 ms0 r0 s0 _ _) = go1 l0 <> ms0 <> go2 r0 <> s0 where 160 | go1 (Closing xs dp :< l') = xs <> (unmatchedClosing dp :< go1 l') 161 | go1 _ = mempty 162 | go2 (r' :> Opening dp ys) = go2 r' <> (unmatchedOpening dp :< ys) 163 | go2 _ = mempty 164 | {-# inline spine #-} 165 | -------------------------------------------------------------------------------- /src/dyck/Token.hsig: -------------------------------------------------------------------------------- 1 | signature Token 2 | ( Token 3 | , Pair 4 | , LayoutMode 5 | , nested 6 | , mismatch 7 | , unmatchedOpening 8 | , unmatchedClosing 9 | , lexicalError 10 | ) where 11 | 12 | import Data.Default 13 | import Data.Ix 14 | import GHC.Generics 15 | 16 | import Relative.Cat 17 | import Relative.Class 18 | import Relative.Delta 19 | import Relative.Located 20 | 21 | data Token 22 | instance Eq Token 23 | instance Ord Token 24 | instance Show Token 25 | instance Read Token 26 | instance Relative Token 27 | 28 | data Pair 29 | instance Eq Pair 30 | instance Ord Pair 31 | instance Show Pair 32 | instance Read Pair 33 | instance Ix Pair 34 | instance Enum Pair 35 | instance Bounded Pair 36 | instance Generic Pair 37 | 38 | data LayoutMode 39 | instance Eq LayoutMode 40 | instance Ord LayoutMode 41 | instance Show LayoutMode 42 | instance Read LayoutMode 43 | instance Default LayoutMode 44 | 45 | nested :: Pair -> Delta -> Cat Token -> Delta -> Token 46 | mismatch :: Located Pair -> Located Pair -> Cat Token -> Token 47 | unmatchedOpening :: Located Pair -> Token 48 | unmatchedClosing :: Located Pair -> Token 49 | lexicalError :: Delta -> String -> Token 50 | -------------------------------------------------------------------------------- /src/layout/Dyck.hsig: -------------------------------------------------------------------------------- 1 | 2 | signature Dyck(Dyck, boring) where 3 | 4 | import Control.Lens 5 | import Data.Default 6 | import Relative.Class 7 | 8 | data Dyck 9 | instance Eq Dyck 10 | instance Show Dyck 11 | instance Relative Dyck 12 | instance Semigroup Dyck 13 | instance AsEmpty Dyck 14 | 15 | boring :: Dyck -> Bool 16 | -------------------------------------------------------------------------------- /src/layout/Parser.hsig: -------------------------------------------------------------------------------- 1 | signature Parser where 2 | 3 | import Dyck 4 | 5 | data Parsed 6 | data Tag a 7 | 8 | parse :: Dyck -> Parsed 9 | retrieve :: Parsed -> Tag a -> a 10 | -------------------------------------------------------------------------------- /src/layout/README.md: -------------------------------------------------------------------------------- 1 | # work in progress 2 | -------------------------------------------------------------------------------- /src/lsp/Language/Server/Builder.hs: -------------------------------------------------------------------------------- 1 | {-# language CPP #-} 2 | {-# language OverloadedStrings #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Copyright : (c) Edward Kmett 2017-2018 7 | -- License : BSD-2-Clause OR Apache-2.0 8 | -- Maintainer : Edward Kmett 9 | -- Stability : experimental 10 | -- Portability : non-portable 11 | -- 12 | -- JSON-RPC 2.0 message serialization 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Language.Server.Builder 17 | ( buildMessage 18 | , buildEncoding 19 | , hPutMessage 20 | , hPutEncoding 21 | , putMessage 22 | , putEncoding 23 | ) where 24 | 25 | import Control.Monad.IO.Class 26 | import Data.Aeson 27 | import Data.ByteString.Builder 28 | import Data.ByteString.Lazy as Lazy 29 | #if __GLASGOW_HASKELL__ < 804 30 | import Data.Monoid 31 | #endif 32 | import System.IO 33 | 34 | -- | Serialize a JSON-RPC 2.0 message. 35 | -- 36 | -- >>> toLazyByteString (buildMessage "hello") 37 | -- "Content-Length: 7\r\n\r\n\"hello\"" 38 | buildMessage :: ToJSON a => a -> Builder 39 | buildMessage = buildEncoding . toEncoding 40 | 41 | -- | Serialize a JSON-RPC 2.0 message from an Encoding 42 | buildEncoding :: Encoding -> Builder 43 | buildEncoding a 44 | = byteString "Content-Length: " <> int64Dec (Lazy.length content) <> byteString "\r\n\r\n" 45 | <> lazyByteString content 46 | where content = toLazyByteString (fromEncoding a) 47 | 48 | -- | Write a JSON-RPC 2.0 message to a given file handle from an Encoding 49 | hPutEncoding :: MonadIO m => Handle -> Encoding -> m () 50 | hPutEncoding h a = liftIO $ do 51 | hPutBuilder h $ buildEncoding a 52 | hFlush h 53 | 54 | -- | Write a JSON-RPC 2.0 message to a given file handle 55 | hPutMessage :: (MonadIO m, ToJSON a) => Handle -> a -> m () 56 | hPutMessage h a = hPutEncoding h (toEncoding a) 57 | 58 | -- | Write a JSON-RPC 2.0 message to stdout 59 | putMessage :: (MonadIO m, ToJSON a) => a -> m () 60 | putMessage = putEncoding . toEncoding 61 | 62 | -- | Write a JSON-RPC 2.0 message to stdout from an Encoding 63 | putEncoding :: MonadIO m => Encoding -> m () 64 | putEncoding = hPutEncoding stdout 65 | -------------------------------------------------------------------------------- /src/lsp/Language/Server/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | {-# language DeriveTraversable #-} 3 | {-# language OverloadedStrings #-} 4 | {-# language DeriveDataTypeable #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Copyright : (c) Edward Kmett 2017-2018 9 | -- License : BSD-2-Clause OR Apache-2.0 10 | -- Maintainer : Edward Kmett 11 | -- Stability : experimental 12 | -- Portability : non-portable 13 | -- 14 | -- JSON-RPC 2.0 message parsing 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module Language.Server.Parser 19 | ( Parser(..) 20 | , ParseResult(..) 21 | , parse 22 | , parseMessage 23 | , decodeMessage 24 | , decodeMessage' 25 | , eitherDecodeMessage 26 | , eitherDecodeMessage' 27 | ) where 28 | 29 | import Control.Monad 30 | import Data.Aeson 31 | import Data.Char 32 | import Data.Data 33 | import qualified Data.ByteString.Lazy as Lazy 34 | import System.IO 35 | import Control.Exception 36 | 37 | -- $setup 38 | -- >>> :set -XOverloadedStrings 39 | 40 | -------------------------------------------------------------------------------- 41 | -- * Lazy ByteString Parsing 42 | -------------------------------------------------------------------------------- 43 | 44 | -- | The result of parsing 45 | data ParseResult a 46 | = Err 47 | | OK !a !Lazy.ByteString 48 | deriving (Show, Functor, Foldable, Traversable) 49 | 50 | -- | LL(1) Parser for streaming directly from file handles. 51 | -- 52 | -- Assumes the input handle has been set to 53 | -- 54 | -- @ 55 | -- 'hSetBuffering' handle 'NoBuffering' 56 | -- 'hSetEncoding' handle 'char8' 57 | -- @ 58 | newtype Parser a = Parser { runParser :: Handle -> IO a } 59 | deriving Functor 60 | 61 | instance Applicative Parser where 62 | pure a = Parser $ \_ -> pure a 63 | (<*>) = ap 64 | (*>) = (>>) 65 | 66 | instance Monad Parser where 67 | Parser m >>= f = Parser $ \h -> m h >>= \a -> runParser (f a) h 68 | instance MonadFail Parser where 69 | fail s = Parser $ \_ -> throw $ ParseError s 70 | 71 | parse :: Parser a -> Handle -> IO (Either String a) 72 | parse p h = (Right <$> runParser p h) `catch` \(ParseError e) -> pure $ Left e 73 | 74 | -- | parse errors for json-rpc frames are basically unrecoverable as there is no real framing 75 | newtype ParseError = ParseError String 76 | deriving (Show, Data) 77 | 78 | instance Exception ParseError 79 | 80 | -- | Parse one byte as an ISO-8859-1 character 81 | ascii :: Parser Char 82 | ascii = Parser hGetChar 83 | 84 | char :: Char -> Parser () 85 | char p = do 86 | q <- ascii 87 | unless (p == q) $ fail $ "expected " ++ show p 88 | 89 | -- | Parse exactly the string specified 90 | string :: Lazy.ByteString -> Parser () 91 | string p = Parser $ \h -> do 92 | q <- Lazy.hGet h (fromIntegral $ Lazy.length p) 93 | unless (p == q) $ fail $ "expected " ++ show p 94 | 95 | -- | Parse to the next carriage return and linefeed inclusively 96 | anyField :: Parser () 97 | anyField = ascii >>= \case 98 | 'r' -> char '\n' 99 | _ -> anyField 100 | 101 | -- | Parse an integer followed by a carriage return linefeed 102 | intField :: Parser Int 103 | intField = do 104 | b <- ascii 105 | unless (isDigit b) $ fail "expected integer" 106 | go (digitToInt b) 107 | where 108 | go :: Int -> Parser Int 109 | go acc = ascii >>= \case 110 | '\r' -> acc <$ char '\n' 111 | d | isDigit d -> go (acc * 10 + digitToInt d) 112 | | otherwise -> fail "expected digit or '\\r'" 113 | 114 | -- | Parse a JSON-RPC 2.0 content header 115 | -- 116 | -- TODO: validate Content-Type 117 | contentHeader :: Parser Int 118 | contentHeader = do 119 | char 'C' -- give an error back one character in 120 | string "ontent-" 121 | ascii >>= \case 122 | 'L' -> string "ength: " *> intField <* rest 123 | 'T' -> string "ype: " *> anyField *> contentHeader 124 | _ -> fail "expected 'L' or 'T'" 125 | where 126 | rest = ascii >>= \case 127 | '\r' -> char '\n' 128 | 'C' -> string "ontent-Type: " *> anyField *> rest 129 | _ -> fail "expected '\\r' or 'C'" 130 | 131 | -- | Consume @n@ bytes 132 | bytes :: Int -> Parser Lazy.ByteString 133 | bytes n = Parser $ \h -> do 134 | bs <- Lazy.hGet h n 135 | let m = fromIntegral (Lazy.length bs) 136 | unless (m == n) $ fail $ "expected " ++ show n ++ " bytes, but only received " ++ show m 137 | pure bs 138 | 139 | -------------------------------------------------------------------------------- 140 | -- * RPC Parsing 141 | -------------------------------------------------------------------------------- 142 | 143 | -- | This parses a JSON-RPC 2.0 message 144 | -- 145 | -- This stops before we get to actually decoding the JSON message. 146 | parseMessage :: Parser Lazy.ByteString 147 | parseMessage = contentHeader >>= bytes 148 | 149 | -- | This decodes a JSON-RPC 2.0 message lazily 150 | -- 151 | -- If the outer parser fails, then the message stream is unrecoverable. If decoding fails, we simply failed to read this message. 152 | decodeMessage :: FromJSON a => Parser (Maybe a) 153 | decodeMessage = decode <$> parseMessage 154 | 155 | -- | This decodes a JSON-RPC 2.0 message eager 156 | -- 157 | -- If the outer parser fails, then the message stream is unrecoverable. If decoding fails, we simply failed to read this message. 158 | decodeMessage' :: FromJSON a => Parser (Maybe a) 159 | decodeMessage' = decode' <$> parseMessage 160 | 161 | -- | This decodes a JSON-RPC 2.0 message lazily with an error message on failure 162 | eitherDecodeMessage :: FromJSON a => Parser (Either String a) 163 | eitherDecodeMessage = eitherDecode <$> parseMessage 164 | 165 | -- | This decodes a JSON-RPC 2.0 message eager with an error message on failure 166 | eitherDecodeMessage' :: FromJSON a => Parser (Either String a) 167 | eitherDecodeMessage' = eitherDecode' <$> parseMessage 168 | -------------------------------------------------------------------------------- /src/lsp/Language/Server/TH.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Copyright : (c) Edward Kmett 2017-2018 4 | -- License : BSD-2-Clause OR Apache-2.0 5 | -- Maintainer: Edward Kmett 6 | -- Stability : experimental 7 | -- Portability: non-portable 8 | -- 9 | -- Bibs and bobs that make it easier to derive lenses and aeson instances 10 | -- 11 | -------------------------------------------------------------------------------- 12 | 13 | 14 | module Language.Server.TH 15 | ( jsonOmit 16 | , jsonKeep 17 | , lenses 18 | ) where 19 | 20 | import Control.Lens 21 | import Data.Aeson.TH 22 | import Data.Char 23 | import Data.Foldable 24 | import Data.List (stripPrefix) 25 | import Language.Haskell.TH 26 | 27 | jsonOmit, jsonKeep :: Name -> Q [Dec] 28 | jsonOmit = deriveJSON defaultOptions { fieldLabelModifier = Prelude.drop 1, omitNothingFields = True } 29 | jsonKeep = deriveJSON defaultOptions { fieldLabelModifier = Prelude.drop 1, omitNothingFields = False } 30 | 31 | special :: [String] 32 | special = ["data","id","class","type"] 33 | 34 | lenses :: Name -> Q [Dec] 35 | lenses = makeLensesWith $ defaultFieldRules & lensField .~ \ _ _ _field -> toList $ do 36 | field <- stripPrefix "_" (nameBase _field) 37 | let className = "Has" ++ (field & _head %~ toUpper) 38 | methodName 39 | | field `elem` special = field ++ "_" 40 | | otherwise = field 41 | return $ MethodName (mkName className) (mkName methodName) 42 | -------------------------------------------------------------------------------- /src/parser/Syntax/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# language GADTs #-} 2 | 3 | module Syntax.Parser where 4 | 5 | import Syntax.Dyck 6 | 7 | data Parsed = Parsed 8 | { parsedNone :: () 9 | , parsedDo :: Bool 10 | } 11 | 12 | data Tag a where 13 | None :: Tag () 14 | Do :: Tag Bool 15 | 16 | parseNone :: Dyck -> () 17 | parseNone _ = () 18 | 19 | parseDo :: Dyck -> Bool 20 | parseDo _ = False 21 | 22 | parse :: Dyck -> Parsed 23 | parse d = Parsed (parseNone d) (parseDo d) 24 | 25 | retrieve :: Parsed -> Tag a -> a 26 | retrieve d None = parsedNone d 27 | retrieve d Do = parsedDo d 28 | -------------------------------------------------------------------------------- /src/relative/Absolute.hs: -------------------------------------------------------------------------------- 1 | {-# language TypeFamilies #-} 2 | {-# language DeriveGeneric #-} 3 | {-# language TemplateHaskell #-} 4 | {-# language FlexibleInstances #-} 5 | {-# language DeriveDataTypeable #-} 6 | {-# language MultiParamTypeClasses #-} 7 | {-# language FunctionalDependencies #-} 8 | 9 | --------------------------------------------------------------------------------- 10 | -- | 11 | -- Copyright : (c) Edward Kmett 2017-2018 12 | -- License : BSD-2-Clause OR Apache-2.0 13 | -- Maintainer: Edward Kmett 14 | -- Stability : experimental 15 | -- Portability: non-portable 16 | -- 17 | --------------------------------------------------------------------------------- 18 | 19 | module Absolute 20 | ( Absolute(..) 21 | ) where 22 | 23 | import Control.Lens 24 | import Data.Data 25 | import Data.Hashable 26 | import Data.Semigroup 27 | import GHC.Generics 28 | import Relative 29 | 30 | -- | Make anything "Relative" trivially. 31 | -- 32 | -- Requests for its 'delta' are passed through unmodified. 33 | newtype Absolute a = Absolute a 34 | deriving (Eq,Ord,Show,Read,Data,Generic) 35 | 36 | makeWrapped ''Absolute 37 | 38 | instance Relative (Absolute a) where rel _ x = x 39 | 40 | instance Ord a => RelativeOrder (Absolute a) 41 | 42 | instance Semigroup a => Semigroup (Absolute a) where 43 | Absolute a <> Absolute b = Absolute (a <> b) 44 | stimes n (Absolute a) = Absolute (stimes n a) 45 | 46 | instance Monoid a => Monoid (Absolute a) where 47 | mempty = Absolute mempty 48 | mappend (Absolute a) (Absolute b) = Absolute (mappend a b) 49 | 50 | instance Semigroup a => RelativeSemigroup (Absolute a) 51 | instance Monoid a => RelativeMonoid (Absolute a) 52 | 53 | instance Ord a => StrictRelativeOrder (Absolute a) 54 | 55 | instance Hashable a => Hashable (Absolute a) 56 | 57 | -- instance HasDelta a => HasDelta (Absolute a) where delta (Absolute a) = delta a 58 | 59 | -- instance HasMonoidalDelta a => HasMonoidalDelta (Absolute a) 60 | 61 | -- instance HasOrderedDelta a => HasOrderedDelta (Absolute a) 62 | -------------------------------------------------------------------------------- /src/relative/Cat.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | {-# language TypeFamilies #-} 3 | {-# language PatternSynonyms #-} 4 | {-# language FlexibleContexts #-} 5 | {-# language FlexibleInstances #-} 6 | {-# language MultiParamTypeClasses #-} 7 | 8 | --------------------------------------------------------------------------------- 9 | -- | 10 | -- Copyright : (c) Edward Kmett 2017-2018 11 | -- License : BSD-2-Clause OR Apache-2.0 12 | -- Maintainer: Edward Kmett 13 | -- Stability : experimental 14 | -- Portability: non-portable 15 | -- 16 | --------------------------------------------------------------------------------- 17 | 18 | module Cat 19 | ( Cat 20 | , snocCat 21 | , singleton 22 | , null 23 | ) where 24 | 25 | import Control.Lens 26 | import Data.Default 27 | import Data.Function (on) 28 | import Data.List (unfoldr) 29 | import Data.Semigroup 30 | import GHC.Exts as Exts 31 | import Text.Read 32 | import Prelude hiding (null) 33 | 34 | import Relative 35 | import Queue (Queue, snocQ) 36 | import qualified Queue 37 | 38 | -- invariant, all recursive cat's are non-empty 39 | data Cat a = E | C a (Queue (Cat a)) 40 | 41 | -- {-# complete E, (:<) #-} 42 | 43 | instance Default (Cat a) where 44 | def = E 45 | 46 | instance Relative a => Relative (Cat a) where 47 | rel _ E = E 48 | rel 0 xs = xs 49 | rel d (C a as) = C (rel d a) (rel d as) 50 | {-# inline rel #-} 51 | 52 | null :: Cat a -> Bool 53 | null E = True 54 | null _ = False 55 | {-# inline null #-} 56 | 57 | instance Relative a => Semigroup (Cat a) where 58 | xs <> E = xs 59 | E <> xs = xs 60 | C x xs <> ys = link x xs ys 61 | {-# inline (<>) #-} 62 | 63 | instance Relative a => Monoid (Cat a) where 64 | mempty = E 65 | mappend = (<>) 66 | 67 | link :: Relative a => a -> Queue (Cat a) -> Cat a -> Cat a 68 | link x q ys = C x (snocQ q ys) 69 | {-# inline link #-} 70 | 71 | -- O(1 + e) where e is the # of empty nodes in the queue 72 | linkAll :: Relative a => Queue (Cat a) -> Cat a 73 | linkAll q = case uncons q of 74 | Just (cat@(C a t), q') 75 | | Queue.null q' -> cat 76 | | otherwise -> link a t (linkAll q') 77 | Just (E, q') -> linkAll q' -- recursive case 78 | Nothing -> E 79 | 80 | instance AsEmpty (Cat a) where 81 | _Empty = prism (const E) $ \case 82 | E -> Right () 83 | xs -> Left xs 84 | 85 | instance (Relative a, Relative b) => Cons (Cat a) (Cat b) a b where 86 | _Cons = prism kons unkons where 87 | kons (a, E) = C a def 88 | kons (a, ys) = link a def ys 89 | {-# inline conlike kons #-} 90 | unkons E = Left E 91 | unkons (C a q) = Right (a, linkAll q) 92 | {-# inline unkons #-} 93 | 94 | instance Relative a => IsList (Cat a) where 95 | type Item (Cat a) = a 96 | fromList = foldr cons E 97 | {-# inline fromList #-} 98 | toList = unfoldr uncons 99 | {-# inline toList #-} 100 | 101 | singleton :: a -> Cat a 102 | singleton a = C a def 103 | {-# inline conlike singleton #-} 104 | 105 | snocCat :: Relative a => Cat a -> a -> Cat a 106 | snocCat xs a = xs <> singleton a 107 | {-# inline snocCat #-} 108 | 109 | instance (Show a, Relative a) => Show (Cat a) where 110 | showsPrec d = showsPrec d . Exts.toList 111 | 112 | instance (Read a, Relative a) => Read (Cat a) where 113 | readPrec = Exts.fromList <$> readPrec 114 | 115 | instance (Eq a, Relative a) => Eq (Cat a) where 116 | (==) = (==) `on` Exts.toList 117 | {-# inline (==) #-} 118 | 119 | instance (Ord a, Relative a) => Ord (Cat a) where 120 | compare = compare `on` Exts.toList 121 | {-# inline compare #-} 122 | 123 | -------------------------------------------------------------------------------- /src/relative/Delta.hsig: -------------------------------------------------------------------------------- 1 | {-# language CPP #-} 2 | --------------------------------------------------------------------------------- 3 | -- | 4 | -- Copyright : (c) Edward Kmett 2017-2018 5 | -- License : BSD2 6 | -- Maintainer: Edward Kmett 7 | -- Stability : experimental 8 | -- Portability: non-portable 9 | -- 10 | --------------------------------------------------------------------------------- 11 | 12 | signature Delta 13 | ( Delta 14 | ) where 15 | 16 | import Data.Data 17 | import Data.Default 18 | import Data.Hashable 19 | #if __GLASGOW_HASKELL__ < 804 20 | import Data.Semigroup 21 | #endif 22 | import GHC.Generics 23 | 24 | data Delta 25 | instance Eq Delta 26 | instance Ord Delta 27 | instance Data Delta 28 | instance Generic Delta 29 | instance Num Delta -- hackishly used with (+) (-) as a group for now 30 | instance Show Delta 31 | instance Read Delta 32 | instance Hashable Delta 33 | instance Default Delta 34 | instance Semigroup Delta 35 | instance Monoid Delta 36 | 37 | -------------------------------------------------------------------------------- /src/relative/List.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | {-# language TypeFamilies #-} 3 | {-# language ViewPatterns #-} 4 | {-# language RoleAnnotations #-} 5 | {-# language PatternSynonyms #-} 6 | {-# language FlexibleInstances #-} 7 | {-# language MultiParamTypeClasses #-} 8 | 9 | --------------------------------------------------------------------------------- 10 | --- | 11 | --- Copyright : (c) Edward Kmett 2017-2018 12 | --- License : BSD-2-Clause OR Apache-2.0 13 | --- Maintainer: Edward Kmett 14 | --- Stability : experimental 15 | --- Portability: non-portable 16 | --- 17 | --------------------------------------------------------------------------------- 18 | 19 | module List 20 | ( List(..) 21 | , pattern Cons 22 | , reverse 23 | ) where 24 | 25 | import Control.Lens (AsEmpty(..), prism, Cons(..)) 26 | import Data.Default 27 | import Data.Function (on) 28 | import Data.Semigroup 29 | import GHC.Exts as Exts hiding(List) 30 | import qualified Prelude 31 | import Prelude hiding (reverse) 32 | import Text.Read 33 | 34 | import Delta 35 | import Relative 36 | 37 | -- | A list with an /O(1)/ 'rel', 'cons' and 'uncons', but /O(n)/ ('<>') 38 | data List a = List !Delta [a] 39 | 40 | type role List nominal 41 | 42 | instance Relative (List a) where 43 | rel 0 xs = xs 44 | rel d (List d' as) = List (d <> d') as 45 | {-# inline rel #-} 46 | 47 | pattern Cons :: Relative a => () => a -> List a -> List a 48 | pattern Cons a as <- List d ((rel d -> a):(List d -> as)) where 49 | Cons a (List d as) = List d (rel (-d) a:as) 50 | 51 | reverse :: List a -> List a 52 | reverse (List d as) = List d (Prelude.reverse as) 53 | {-# inline reverse #-} 54 | 55 | instance (Show a, Relative a) => Show (List a) where 56 | showsPrec d = showsPrec d . Exts.toList 57 | 58 | instance (Read a, Relative a) => Read (List a) where 59 | readPrec = Exts.fromList <$> readPrec 60 | 61 | instance (Eq a, Relative a) => Eq (List a) where 62 | (==) = (==) `on` Exts.toList 63 | {-# inline (==) #-} 64 | 65 | instance (Ord a, Relative a) => Ord (List a) where 66 | compare = compare `on` Exts.toList 67 | {-# inline compare #-} 68 | 69 | instance RelativeOrder a => RelativeOrder (List a) 70 | instance StrictRelativeOrder a => StrictRelativeOrder (List a) 71 | instance Relative a => RelativeSemigroup (List a) 72 | instance Relative a => RelativeMonoid (List a) 73 | 74 | instance Default (List a) where 75 | def = List 0 [] 76 | 77 | -- /O(n)/ 78 | instance Relative a => Semigroup (List a) where 79 | List d as <> List d' bs | d'' <- d'-d = List d $ as ++ map (rel d'') bs 80 | {-# inline (<>) #-} 81 | 82 | -- /O(n)/ 83 | instance Relative a => Monoid (List a) where 84 | mempty = List 0 [] 85 | mappend = (<>) 86 | 87 | instance Relative a => IsList (List a) where 88 | type Item (List a) = a 89 | fromList = List 0 90 | {-# inline conlike fromList #-} 91 | toList (List d xs) = map (rel d) xs 92 | {-# inline toList #-} 93 | 94 | instance AsEmpty (List a) where 95 | _Empty = prism (const def) $ \case 96 | List _ [] -> Right () 97 | xs -> Left xs 98 | {-# inline _Empty #-} 99 | 100 | instance (Relative a, Relative b) => Cons (List a) (List b) a b where 101 | _Cons = prism (\(a,List d as) -> List d (rel (-d) a:as)) $ \case 102 | List _ [] -> Left mempty 103 | List d (a:as) -> Right (rel d a, List d as) 104 | {-# inline _Cons #-} 105 | -------------------------------------------------------------------------------- /src/relative/Located.hs: -------------------------------------------------------------------------------- 1 | {-# language CPP #-} 2 | {-# language DeriveGeneric #-} 3 | {-# language DeriveTraversable #-} 4 | {-# language DeriveDataTypeable #-} 5 | {-# language UndecidableInstances #-} 6 | {-# language MultiParamTypeClasses #-} 7 | 8 | --------------------------------------------------------------------------------- 9 | --- | 10 | --- Copyright : (c) Edward Kmett 2017-2018 11 | --- License : BSD-2-Clause OR Apache-2.0 12 | --- Maintainer: Edward Kmett 13 | --- Stability : experimental 14 | --- Portability: non-portable 15 | --- 16 | --------------------------------------------------------------------------------- 17 | 18 | module Located 19 | ( Located(..) 20 | ) where 21 | 22 | import Control.Applicative 23 | import Control.Comonad 24 | import Control.Monad (ap) 25 | import Control.Monad.Writer.Class 26 | import Data.Data 27 | import Data.Default 28 | import Data.Hashable 29 | import Data.Hashable.Lifted 30 | #if __GLASGOW_HASKELL__ < 804 31 | import Data.Semigroup 32 | #endif 33 | import GHC.Generics 34 | 35 | import Data.Functor.Classes 36 | 37 | import Algebra.Ordered 38 | import Relative 39 | import Delta 40 | 41 | -- | Place a non-relative data type at a given position 42 | -- 43 | -- Note: 'Located' is not a 'RelativeMonoid' as @'rel' 1 'mempty' '/=' 'mempty'@ 44 | data Located a = Located !Delta a 45 | deriving (Eq, Ord, Show, Read, Data, Generic, Functor, Foldable, Traversable) 46 | 47 | instance Hashable a => Hashable (Located a) 48 | 49 | instance Eq1 Located where 50 | liftEq eq (Located _ x) (Located _ y) = eq x y 51 | 52 | instance Hashable1 Located where 53 | liftHashWithSalt f s (Located d a) = f (hashWithSalt s d) a 54 | 55 | instance Applicative Located where 56 | pure = Located mempty 57 | (<*>) = ap 58 | 59 | instance Monad Located where 60 | Located d a >>= f = case f a of 61 | Located d' b -> Located (d <> d') b 62 | 63 | instance Comonad Located where 64 | extract (Located _ a) = a 65 | extend f w@(Located d _) = Located d (f w) 66 | 67 | instance Semigroup a => Semigroup (Located a) where 68 | (<>) = liftA2 (<>) 69 | 70 | instance Monoid a => Monoid (Located a) where 71 | mempty = pure mempty 72 | mappend = liftA2 mappend 73 | 74 | instance MonadWriter Delta Located where 75 | tell d = Located d () 76 | pass (Located d (a, f)) = Located (f d) a 77 | listen (Located d a) = Located d (a, d) 78 | 79 | instance Relative (Located a) where 80 | rel d (Located d' a) = Located (d <> d') a 81 | 82 | instance Ord a => RelativeOrder (Located a) 83 | instance Ord a => StrictRelativeOrder (Located a) 84 | instance OrderedMonoid a => OrderedMonoid (Located a) 85 | 86 | instance Default a => Default (Located a) where 87 | def = Located mempty def 88 | 89 | -- instance HasDelta (Located a) where delta (Located d _) = d 90 | -- instance Ord a => HasOrderedDelta (Located a) 91 | -- instance Monoid a => HasMonoidalDelta (Located a) 92 | -- instance HasRelativeDelta (Located a) 93 | -------------------------------------------------------------------------------- /src/relative/Queue.hs: -------------------------------------------------------------------------------- 1 | {-# language LambdaCase #-} 2 | {-# language TypeFamilies #-} 3 | {-# language FlexibleInstances #-} 4 | {-# language MultiParamTypeClasses #-} 5 | 6 | --------------------------------------------------------------------------------- 7 | -- | 8 | -- Copyright : (c) Edward Kmett 2017-2018 9 | -- License : BSD-2-Clause OR Apache-2.0 10 | -- Maintainer: Edward Kmett 11 | -- Stability : experimental 12 | -- Portability: non-portable 13 | -- 14 | -- Okasaki real-time queue modified for /O(1)/ @rel@ 15 | -- 16 | --------------------------------------------------------------------------------- 17 | 18 | module Queue 19 | ( Queue((:<),Empty) 20 | , snocQ 21 | , size 22 | , null 23 | ) where 24 | 25 | import Control.Lens 26 | import Data.Default 27 | import Data.Function (on) 28 | import Data.List (unfoldr) 29 | import Data.Semigroup 30 | import GHC.Exts as Exts 31 | import Text.Read 32 | import Prelude hiding (null) 33 | 34 | import Relative 35 | import Delta 36 | 37 | -- @Q d f r s@ maintains @length s = length f - length r@ 38 | data Queue a = Q {-# unpack #-} !Delta [a] [a] [a] 39 | 40 | instance Relative (Queue a) where 41 | rel 0 q = q 42 | rel d (Q d' f r s) = Q (d <> d') f r s 43 | 44 | instance Default (Queue a) where 45 | def = Q 0 [] [] [] 46 | 47 | size :: Queue a -> Int 48 | size (Q _ _ rs ss) = length ss + 2 * length rs 49 | 50 | null :: Queue a -> Bool 51 | null (Q _ [] _ _) = True 52 | null _ = False 53 | 54 | instance Relative a => IsList (Queue a) where 55 | type Item (Queue a) = a 56 | fromList = foldr cons def 57 | {-# inline fromList #-} 58 | toList = unfoldr uncons 59 | {-# inline toList #-} 60 | 61 | instance AsEmpty (Queue a) where 62 | _Empty = prism (const $ Q 0 [] [] []) $ \case 63 | Q _ [] _ _ -> Right () 64 | xs -> Left xs 65 | {-# inline _Empty #-} 66 | 67 | instance (Relative a, Relative b) => Cons (Queue a) (Queue b) a b where 68 | _Cons = prism kons unkons where 69 | kons (a, Q d f r s) | a' <- rel (-d) a = Q d (a':f) r (a':s) 70 | {-# inline conlike kons #-} 71 | unkons (Q _ [] _ _) = Left def 72 | unkons (Q d (x:f) r s) = Right (rel d x, exec d f r s) 73 | {-# inline _Cons #-} 74 | 75 | snocQ :: Relative a => Queue a -> a -> Queue a 76 | snocQ (Q d f r s) a = exec d f (rel (-d) a:r) s 77 | {-# inline snocQ #-} 78 | 79 | instance (Show a, Relative a) => Show (Queue a) where 80 | showsPrec d = showsPrec d . Exts.toList 81 | 82 | instance (Read a, Relative a) => Read (Queue a) where 83 | readPrec = Exts.fromList <$> readPrec 84 | 85 | instance (Eq a, Relative a) => Eq (Queue a) where 86 | (==) = (==) `on` Exts.toList 87 | {-# inline (==) #-} 88 | 89 | instance (Ord a, Relative a) => Ord (Queue a) where 90 | compare = compare `on` Exts.toList 91 | {-# inline compare #-} 92 | 93 | exec :: Delta -> [a] -> [a] -> [a] -> Queue a 94 | exec d f r (_:s) = Q d f r s 95 | exec d f r [] = Q d f' [] f' where f' = rotate f r [] 96 | {-# inline exec #-} 97 | 98 | rotate :: [a] -> [a] -> [a] -> [a] 99 | rotate [] (y:_) a = y:a 100 | rotate (x:xs) (y:ys) a = x : rotate xs ys (y:a) 101 | rotate _ _ _ = error "Coda.Relative.Queue.rotate: invariant broken" 102 | -------------------------------------------------------------------------------- /src/relative/Semi.hs: -------------------------------------------------------------------------------- 1 | module Semi 2 | ( Semi(..) 3 | ) where 4 | 5 | import Delta 6 | import Relative 7 | 8 | -------------------------------------------------------------------------------- 9 | -- Semi-direct products 10 | -------------------------------------------------------------------------------- 11 | 12 | data Semi a = Semi {-# unpack #-} !Delta a 13 | deriving (Eq,Ord,Show,Read) 14 | 15 | instance RelativeSemigroup a => Semigroup (Semi a) where 16 | Semi a b <> Semi c d = Semi (a <> c) (b <> rel a d) 17 | 18 | instance RelativeMonoid a => Monoid (Semi a) where 19 | mempty = Semi mempty mempty 20 | mappend = (<>) 21 | 22 | instance Relative a => Relative (Semi a) where 23 | rel 0 xs = xs 24 | rel d (Semi d' a) = Semi (d+d') (rel d a) 25 | 26 | instance RelativeSemigroup a => RelativeSemigroup (Semi a) 27 | instance RelativeMonoid a => RelativeMonoid (Semi a) 28 | instance RelativeOrder a => RelativeOrder (Semi a) 29 | instance StrictRelativeOrder a => StrictRelativeOrder (Semi a) 30 | -------------------------------------------------------------------------------- /src/rope/Document.hs: -------------------------------------------------------------------------------- 1 | {-# language DuplicateRecordFields #-} 2 | {-# language TemplateHaskell #-} 3 | {-# language MultiParamTypeClasses #-} 4 | {-# language FunctionalDependencies #-} 5 | {-# language OverloadedStrings #-} 6 | {-# language FlexibleContexts #-} 7 | {-# language UndecidableInstances #-} 8 | {-# language TypeFamilies #-} 9 | 10 | --------------------------------------------------------------------------------- 11 | -- | 12 | -- Copyright : (c) Edward Kmett 2017-2018 13 | -- License : BSD-2-Clause OR Apache-2.0 14 | -- Maintainer: Edward Kmett 15 | -- Stability : experimental 16 | -- Portability: non-portable 17 | -- 18 | --------------------------------------------------------------------------------- 19 | 20 | module Document 21 | ( Document(..) 22 | , Documents 23 | , HasDocuments(..) 24 | , HasLanguageId(..) 25 | , HasVersion(..) 26 | , HasContents(..) 27 | , HasOpen(..) 28 | , didOpen 29 | , didChange 30 | , didSave 31 | , didClose 32 | ) where 33 | 34 | import Control.Lens 35 | import Control.Monad.State 36 | 37 | import Data.Foldable (for_) 38 | import Data.Function (on) 39 | import Data.HashMap.Strict hiding (foldr) 40 | import Data.List (sortBy) 41 | import Data.Text as Text hiding (foldr) 42 | 43 | import Language.Server.Protocol 44 | import FingerTree (Measured(..)) 45 | 46 | import Rope 47 | 48 | data Document = Document 49 | { _languageId :: !Text 50 | , _version :: {-# unpack #-} !Int 51 | , _contents :: !Rope 52 | , _open :: !Bool 53 | , _changed :: !Bool -- differs from the contents on disk 54 | } deriving Show 55 | 56 | type Documents = HashMap DocumentUri Document 57 | 58 | instance Measured Document where 59 | type Measure Document = LineMeasure 60 | measure = views contents measure 61 | 62 | makeFieldsNoPrefix ''Document 63 | 64 | class HasDocuments t d | t -> d where 65 | documents :: Lens' t d 66 | 67 | didOpen :: (MonadState s m, HasDocuments s Documents) => TextDocumentItem -> m () 68 | didOpen (TextDocumentItem u l v t) = documents.at u ?= Document l v (fromText t) True False 69 | 70 | didChange :: (MonadState s m, HasDocuments s Documents) => DidChangeTextDocumentParams -> m () 71 | didChange (DidChangeTextDocumentParams (VersionedTextDocumentIdentifier u v) cs) = 72 | modifying (documents.ix u) $ execState $ do 73 | changed .= True 74 | version .= v 75 | modifying contents $ foldr apply ?? sortBy (compare `on` view range) cs 76 | where 77 | apply (TextDocumentContentChangeEvent (Just rng) _ "") = deleteRange rng 78 | apply (TextDocumentContentChangeEvent (Just rng) _ t) = replaceRange rng t 79 | apply (TextDocumentContentChangeEvent Nothing _ t) = const $ fromText t 80 | 81 | didSave :: (MonadState s m, HasDocuments s Documents) => DidSaveTextDocumentParams -> m () 82 | didSave (DidSaveTextDocumentParams t mt) = 83 | modifying (documents.ix (t^.uri)) $ execState $ do 84 | for_ mt $ \i -> contents .= fromText i 85 | changed .= False 86 | 87 | didClose :: (MonadState s m, HasDocuments s (HashMap DocumentUri a)) => TextDocumentIdentifier -> m () 88 | didClose t = documents.at (t^.uri) .= Nothing 89 | -------------------------------------------------------------------------------- /src/rope/Dyck.hsig: -------------------------------------------------------------------------------- 1 | signature Dyck 2 | ( Dyck 3 | ) where 4 | 5 | data Dyck 6 | instance Eq Dyck 7 | instance Ord Dyck 8 | instance Show Dyck 9 | instance Read Dyck 10 | -------------------------------------------------------------------------------- /src/rope/Lexer.hsig: -------------------------------------------------------------------------------- 1 | signature Lexer 2 | ( lex 3 | ) where 4 | 5 | import Data.Text 6 | import Prelude hiding (lex) 7 | 8 | import Dyck 9 | 10 | lex :: Text -> Dyck 11 | -------------------------------------------------------------------------------- /src/rope/Summary.hsig: -------------------------------------------------------------------------------- 1 | signature Summary 2 | ( Summary 3 | , summarize 4 | , mergeSummary 5 | ) where 6 | 7 | import Data.Data 8 | import Data.Default 9 | import Data.Hashable 10 | import Data.Text 11 | 12 | import Relative.Delta 13 | 14 | import Dyck 15 | 16 | data Summary 17 | instance Data Summary 18 | instance Default Summary 19 | instance Eq Summary 20 | instance Hashable Summary 21 | instance Ord Summary 22 | instance Read Summary 23 | instance Show Summary 24 | 25 | summarize :: Text -> Dyck -> Summary 26 | mergeSummary :: Int -> Delta -> Summary -> Int -> Delta -> Summary -> Summary 27 | -------------------------------------------------------------------------------- /src/server/Server/Options.hs: -------------------------------------------------------------------------------- 1 | {-# language TemplateHaskell #-} 2 | {-# language DeriveDataTypeable #-} 3 | 4 | -------------------------------------------------------------------- 5 | -- | 6 | -- Copyright : (c) Edward Kmett 2017-2018 7 | -- License : BSD-2-Clause OR Apache-2.0 8 | -- Maintainer: Edward Kmett 9 | -- Stability : experimental 10 | -- Portability: non-portable 11 | -- 12 | -------------------------------------------------------------------- 13 | 14 | module Server.Options 15 | ( ServerOptions(..) 16 | , HasServerOptions(..) 17 | , parseServerOptions 18 | ) where 19 | 20 | import Control.Lens 21 | import Data.Data 22 | import Data.Default 23 | import Options.Applicative as Options 24 | 25 | -- | Options for @coda server@ 26 | data ServerOptions = ServerOptions 27 | { _serverOptionsDebug :: !Bool 28 | , _serverOptionsLog :: !(Maybe FilePath) 29 | } deriving (Eq,Ord,Show,Read,Data) 30 | 31 | instance Default ServerOptions where 32 | def = ServerOptions False Nothing 33 | 34 | -- | Parse @coda server@ options 35 | parseServerOptions :: Options.Parser ServerOptions 36 | parseServerOptions = ServerOptions 37 | <$> switch (long "debug" <> help "enable debugging") 38 | <*> optional (strOption (long "log" <> short 'l' <> help "log file" <> metavar "FILE" <> action "file")) 39 | 40 | makeClassy ''ServerOptions 41 | -------------------------------------------------------------------------------- /src/set/Elem.hsig: -------------------------------------------------------------------------------- 1 | signature Elem where 2 | 3 | data Elem 4 | instance Eq Elem 5 | instance Ord Elem 6 | -------------------------------------------------------------------------------- /src/set/Set.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Set 4 | -- Copyright : (c) Daan Leijen 2002 5 | -- License : BSD-style 6 | -- Maintainer : libraries@haskell.org 7 | -- Portability : portable 8 | -- 9 | -- An efficient implementation of sets using backpack to unpack the element type 10 | -- 11 | -- These modules are intended to be imported qualified, to avoid name 12 | -- clashes with Prelude functions, e.g. 13 | -- 14 | -- > import Data.Set (Set) 15 | -- > import qualified Data.Set as Set 16 | -- 17 | -- The implementation of 'Set' is based on /size balanced/ binary trees (or 18 | -- trees of /bounded balance/) as described by: 19 | -- 20 | -- * Stephen Adams, \"/Efficient sets: a balancing act/\", 21 | -- Journal of Functional Programming 3(4):553-562, October 1993, 22 | -- . 23 | -- * J. Nievergelt and E.M. Reingold, 24 | -- \"/Binary search trees of bounded balance/\", 25 | -- SIAM journal of computing 2(1), March 1973. 26 | -- 27 | -- Bounds for 'union', 'intersection', and 'difference' are as given 28 | -- by 29 | -- 30 | -- * Guy Blelloch, Daniel Ferizovic, and Yihan Sun, 31 | -- \"/Just Join for Parallel Ordered Sets/\", 32 | -- . 33 | -- 34 | -- Note that the implementation is /left-biased/ -- the elements of a 35 | -- first argument are always preferred to the second, for example in 36 | -- 'union' or 'insert'. Of course, left-biasing can only be observed 37 | -- when equality is an equivalence relation instead of structural 38 | -- equality. 39 | -- 40 | -- /Warning/: The size of the set must not exceed @maxBound::Int@. Violation of 41 | -- this condition is not detected and if the size limit is exceeded, its 42 | -- behaviour is undefined. 43 | ----------------------------------------------------------------------------- 44 | 45 | module Set ( 46 | -- * Strictness properties 47 | -- $strictness 48 | 49 | -- * Set type 50 | Set 51 | 52 | -- * Operators 53 | , (\\) 54 | 55 | -- * Query 56 | , S.null 57 | , size 58 | , member 59 | , notMember 60 | , lookupLT 61 | , lookupGT 62 | , lookupLE 63 | , lookupGE 64 | , isSubsetOf 65 | , isProperSubsetOf 66 | 67 | -- * Construction 68 | , empty 69 | , singleton 70 | , insert 71 | , delete 72 | 73 | -- * Combine 74 | , union 75 | , unions 76 | , difference 77 | , intersection 78 | 79 | -- * Filter 80 | , S.filter 81 | , takeWhileAntitone 82 | , dropWhileAntitone 83 | , spanAntitone 84 | , partition 85 | , split 86 | , splitMember 87 | , splitRoot 88 | 89 | -- * Indexed 90 | , lookupIndex 91 | , findIndex 92 | , elemAt 93 | , deleteAt 94 | , S.take 95 | , S.drop 96 | , S.splitAt 97 | 98 | -- * Map 99 | , S.map 100 | , mapMonotonic 101 | 102 | -- * Folds 103 | , S.foldMap 104 | , S.foldr 105 | , S.foldl 106 | -- ** Strict folds 107 | , foldr' 108 | , foldl' 109 | 110 | -- * Min\/Max 111 | , lookupMin 112 | , lookupMax 113 | , findMin 114 | , findMax 115 | , deleteMin 116 | , deleteMax 117 | , deleteFindMin 118 | , deleteFindMax 119 | , maxView 120 | , minView 121 | 122 | -- * Conversion 123 | 124 | -- ** List 125 | , elems 126 | , toList 127 | , fromList 128 | 129 | -- ** Ordered list 130 | , toAscList 131 | , toDescList 132 | , fromAscList 133 | , fromDescList 134 | , fromDistinctAscList 135 | , fromDistinctDescList 136 | 137 | -- * Debugging 138 | , showTree 139 | , showTreeWith 140 | , valid 141 | ) where 142 | 143 | import Set.Internal as S 144 | 145 | -- $strictness 146 | -- 147 | -- This module satisfies the following strictness property: 148 | -- 149 | -- * Key arguments are evaluated to WHNF 150 | -- 151 | -- Here are some examples that illustrate the property: 152 | -- 153 | -- > delete undefined s == undefined 154 | -------------------------------------------------------------------------------- /src/summary-unit/Dyck.hsig: -------------------------------------------------------------------------------- 1 | signature Dyck (Dyck) where 2 | 3 | data Dyck 4 | -------------------------------------------------------------------------------- /src/summary-unit/Summary.hs: -------------------------------------------------------------------------------- 1 | module Summary 2 | ( Summary 3 | , summarize 4 | , mergeSummary 5 | ) where 6 | 7 | import Data.Text 8 | 9 | import Relative.Delta.Type 10 | 11 | import Dyck 12 | 13 | type Summary = () 14 | 15 | summarize :: Text -> Dyck -> Summary 16 | summarize _ _ = () 17 | 18 | mergeSummary :: Int -> Delta -> Summary -> Int -> Delta -> Summary -> Summary 19 | mergeSummary _ _ _ _ _ _ = () 20 | -------------------------------------------------------------------------------- /src/syntax/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Syntax where 2 | -------------------------------------------------------------------------------- /src/termination/Termination.hs: -------------------------------------------------------------------------------- 1 | module Termination 2 | ( module Termination.Class 3 | , module Termination.History 4 | , module Termination.Test 5 | ) where 6 | 7 | import Termination.Class 8 | import Termination.History 9 | import Termination.Test 10 | -------------------------------------------------------------------------------- /src/termination/Termination/Class.hs: -------------------------------------------------------------------------------- 1 | {-# language DefaultSignatures #-} 2 | {-# language FlexibleContexts #-} 3 | {-# language MonoLocalBinds #-} 4 | {-# language TypeApplications #-} 5 | 6 | module Termination.Class 7 | ( Termination(..) 8 | , Termination1(..) 9 | ) where 10 | 11 | import Termination.Test 12 | import Data.Functor.Contravariant.Generic 13 | import Data.Proxy 14 | import Numeric.Natural 15 | 16 | class Termination a where 17 | wqo :: Test a 18 | default wqo :: Deciding Termination a => Test a 19 | wqo = deciding (Proxy @Termination) wqo 20 | 21 | instance Termination () 22 | instance Termination a => Termination [a] 23 | instance Termination a => Termination (Maybe a) 24 | instance (Termination a, Termination b) => Termination (Either a b) 25 | instance (Termination a, Termination b) => Termination (a, b) 26 | instance Termination Int where wqo = ord 27 | instance Termination Word where wqo = ord 28 | instance Termination Natural where wqo = ord 29 | 30 | class Termination1 f where 31 | wqo1 :: Test a -> Test (f a) 32 | default wqo1 :: Deciding1 Termination f => Test a -> Test (f a) 33 | wqo1 = deciding1 (Proxy @Termination) wqo 34 | 35 | instance Termination1 [] 36 | instance Termination1 Maybe 37 | instance Termination e => Termination1 ((,) e) 38 | instance Termination e => Termination1 (Either e) 39 | -------------------------------------------------------------------------------- /src/termination/Termination/History.hs: -------------------------------------------------------------------------------- 1 | {-# language GADTs #-} 2 | 3 | -- | Accumulated history for a termination check 4 | 5 | module Termination.History 6 | ( History(..) 7 | , test 8 | ) where 9 | 10 | import Data.Functor.Contravariant 11 | 12 | data History a where 13 | History :: (s -> a -> Maybe s) -> s -> History a 14 | 15 | instance Contravariant History where 16 | contramap f (History g s) = History (\xs a -> g xs (f a)) s 17 | 18 | test :: History a -> a -> Maybe (History a) 19 | test (History k s) a = History k <$> k s a 20 | -------------------------------------------------------------------------------- /src/termination/Termination/Pair.hs: -------------------------------------------------------------------------------- 1 | {-# language CPP #-} 2 | -------------------------------------------------------------------------------- 3 | -- | Efficient Boolean Pairs 4 | -------------------------------------------------------------------------------- 5 | module Termination.Pair where 6 | 7 | import Data.Bits 8 | #if __GLASGOW_HASKELL__ < 804 9 | import Data.Semigroup 10 | #endif 11 | import GHC.Arr 12 | 13 | 14 | -- boolean pairs 15 | data BB = FF | FT | TF | TT deriving (Eq,Ord,Show,Read,Enum,Ix) 16 | 17 | -- logical and 18 | instance Semigroup BB where 19 | x <> y = toEnum (fromEnum x .&. fromEnum y) 20 | 21 | instance Monoid BB where 22 | mempty = FF 23 | mappend = (<>) 24 | 25 | bb1 :: BB -> Bool 26 | bb1 x = testBit (fromEnum x) 2 27 | 28 | bb2 :: BB -> Bool 29 | bb2 x = testBit (fromEnum x) 1 30 | 31 | bb :: Bool -> Bool -> BB 32 | bb False False = FF 33 | bb False True = FT 34 | bb True False = TF 35 | bb True True = TT 36 | 37 | diagBB :: Bool -> BB 38 | diagBB True = TT 39 | diagBB False = FF 40 | 41 | ordBB :: Ordering -> BB 42 | ordBB LT = TF 43 | ordBB EQ = TT 44 | ordBB GT = FT 45 | 46 | pordBB :: Maybe Ordering -> BB 47 | pordBB = maybe FF ordBB 48 | -------------------------------------------------------------------------------- /src/termination/Termination/Test.hs: -------------------------------------------------------------------------------- 1 | {-# language CPP #-} 2 | {-# language ViewPatterns #-} 3 | {-# language GADTs #-} 4 | {-# language ParallelListComp #-} 5 | {-# language BangPatterns #-} 6 | 7 | -- | 8 | -- 9 | -- Well-Quasi-Orders 10 | -- 11 | -- Based on 12 | -- by Bolingbroke et al. 13 | 14 | module Termination.Test where 15 | 16 | import Termination.History 17 | import Termination.Pair 18 | import Control.Arrow 19 | import Data.Functor.Contravariant 20 | import Data.Functor.Contravariant.Divisible 21 | #if __GLASGOW_HASKELL__ < 804 22 | import Data.Semigroup 23 | #endif 24 | import Data.Void 25 | 26 | -- | A well quasi-order: A reflexive, transitive relation such that 27 | -- and every infinite set xs has i < j such that (xs!i) <= (xs!j) 28 | -- returns both x <= y and y <= x simultaneously, and uses a function 29 | -- for more efficient prep 30 | data Test a where 31 | Test :: (a -> s) -> (s -> s -> BB) -> Test a 32 | 33 | runTest :: Test a -> a -> a -> Bool 34 | runTest (Test p f) a b = bb1 $ f (p a) (p b) 35 | 36 | instance Contravariant Test where 37 | contramap f (Test g k) = Test (g . f) k 38 | 39 | instance Divisible Test where 40 | conquer = Test id mempty 41 | divide f (Test p g) (Test q h) = Test pq gh where 42 | pq (f -> (l, r)) = (l', r') where !l' = p l; !r' = q r 43 | gh (a, b) (c, d) = g a c <> h b d 44 | 45 | instance Decidable Test where 46 | lose f = Test f absurd 47 | choose f (Test p g) (Test q h) = Test (fmap (p+++q) f) step where 48 | step (Left a) (Left b) = g a b 49 | step (Right a) (Right b) = h a b 50 | step _ _ = FF 51 | 52 | instance Semigroup (Test a) where 53 | Test p g <> Test q h = Test (p &&& q) $ \(a,b) (c,d) -> g a c <> h b d 54 | 55 | instance Monoid (Test a) where 56 | mempty = conquer 57 | mappend = (<>) 58 | 59 | -- set :: Ord a => Test a -> Test [a] 60 | -- set (Test f p) = Test (map f) $ \xs ys -> go xs ys `bb` go ys xs where 61 | -- go xs ys = all (\x -> any (\y -> bb1 $ p x y) ys) xs 62 | 63 | -- side-condition: needs 'a' to be finitely enumerable 64 | finite :: Eq a => Test a 65 | finite = Test id $ \x y -> diagBB $ x == y -- symmetric 66 | 67 | -- side-condition: well-founded 68 | ord :: Ord a => Test a 69 | ord = Test id $ \x y -> ordBB $ compare x y 70 | 71 | -- @partial f@ requires f is a well-partial-order 72 | partial :: (a -> a -> Maybe Ordering) -> Test a 73 | partial f = Test id $ \x y -> pordBB $ f x y 74 | 75 | history :: Test a -> History a 76 | history (Test p f) = History step [] where 77 | step xs x 78 | | any bb1 ys = Nothing 79 | | otherwise = Just $ z : [ x' | x' <- xs | False <- bb2 <$> ys ] where 80 | z = p x 81 | ys = f z <$> xs 82 | -------------------------------------------------------------------------------- /src/termination/Termination/Trie.hs: -------------------------------------------------------------------------------- 1 | {-# language CPP #-} 2 | {-# language GADTs #-} 3 | {-# language RankNTypes #-} 4 | {-# language LambdaCase #-} 5 | 6 | -- | 7 | -- 8 | -- Well-Quasi-Orders using tries 9 | 10 | module Termination.Trie 11 | ( Trie(..) 12 | , runTrie 13 | , finite 14 | , finiteOrd 15 | , finiteHash 16 | , history 17 | ) where 18 | 19 | import Data.Functor 20 | import Data.Functor.Identity 21 | import Data.Functor.Compose 22 | import Data.Functor.Contravariant 23 | import Data.Functor.Contravariant.Divisible 24 | import Data.Functor.Product 25 | import Data.Coerce 26 | import Data.Map as Map 27 | import Data.Hashable 28 | import Data.HashMap.Strict as HashMap 29 | import Data.Maybe 30 | import Data.Proxy 31 | #if __GLASGOW_HASKELL__ < 804 32 | import Data.Semigroup 33 | #endif 34 | import Data.Void 35 | 36 | import Termination.History 37 | 38 | -- | A well quasi-order: A reflexive, transitive relation such that 39 | -- and every infinite set xs has i < j such that (xs!i) <= (xs!j) 40 | -- encoded as a procedure for maintaining 'xs' in an easily testable form 41 | 42 | -- This is an experiment to see if we can use a trie-based encoding. 43 | -- How to handle orders? 44 | 45 | data Trie a where Trie :: (forall x. x -> f x) -> (forall x. a -> x -> (x -> Maybe x) -> f x -> Maybe (f x)) -> Trie a 46 | 47 | instance Contravariant Trie where 48 | contramap f (Trie h g) = Trie h (g . f) 49 | 50 | instance Divisible Trie where 51 | conquer = Trie Identity (\_ _ -> coerce :: (x -> Maybe x) -> Identity x -> Maybe (Identity x)) 52 | divide f (Trie p g) (Trie q h) = Trie (Compose . p . q) $ \a d k -> case f a of 53 | (b, c) -> fmap Compose . g b (q d) (h c d k) . getCompose 54 | 55 | instance Decidable Trie where 56 | lose f = Trie (const Proxy) (absurd . f) 57 | choose f (Trie p g) (Trie q h) = Trie (\a -> Pair (p a) (q a)) $ \a d k (Pair x y) -> case f a of 58 | Left b -> (`Pair` y) <$> g b d k x 59 | Right c -> Pair x <$> h c d k y 60 | 61 | instance Semigroup (Trie a) where 62 | Trie p g <> Trie q h = Trie (Compose . p . q) $ \a d k -> fmap Compose . g a (q d) (h a d k) . getCompose 63 | 64 | instance Monoid (Trie a) where 65 | mempty = conquer 66 | mappend = (<>) 67 | 68 | seen :: Bool -> Maybe Bool 69 | seen True = Nothing 70 | seen False = Just True 71 | 72 | runTrie :: Trie a -> a -> a -> Bool 73 | runTrie (Trie p f) a b = isJust $ f a False seen (p False) >>= f b False seen 74 | 75 | newtype V a b = V [(a,b)] 76 | 77 | -- side-condition: needs 'a' to be finitely enumerable -- linear time 78 | finite :: Eq a => Trie a 79 | finite = Trie (const $ V []) $ \a d k (V xs) -> fini a xs $ step a d k xs where 80 | fini :: a -> [(a,x)] -> Either (Maybe x) [(a,x)] -> Maybe (V a x) 81 | fini _ _ (Left Nothing) = Nothing 82 | fini a xs (Left (Just d')) = Just $ V $ (a,d'):xs 83 | fini _ _ (Right ys) = Just $ V ys 84 | step :: Eq a => a -> x -> (x -> Maybe x) -> [(a,x)] -> Either (Maybe x) [(a,x)] 85 | step _ d k [] = Left (k d) 86 | step a d k ((b,x):xs) 87 | | a /= b = ((b,x):) <$> step a d k xs 88 | | otherwise = case k x of 89 | Nothing -> Left Nothing 90 | Just x' -> Right ((b,x'):xs) 91 | 92 | -- side-condition: needs 'a' to be finitely enumerable and have an 'Ord' instance -- log time 93 | finiteOrd :: Ord a => Trie a 94 | finiteOrd = Trie (const mempty) $ \ a d k -> Map.alterF (fmap Just . k . fromMaybe d) a 95 | 96 | atH :: (Functor f, Hashable k, Eq k) => k -> (Maybe a -> f (Maybe a)) -> HashMap k a -> f (HashMap k a) 97 | atH k f m = f mv <&> \case 98 | Nothing -> maybe m (const (HashMap.delete k m)) mv 99 | Just v' -> HashMap.insert k v' m 100 | where mv = HashMap.lookup k m 101 | 102 | finiteHash :: (Hashable a, Eq a) => Trie a 103 | finiteHash = Trie (const mempty) $ \a d k -> atH a (fmap Just . k . fromMaybe d) 104 | 105 | -- can I handle orders? I can't compile down to a test, can I incorporate tests as another constructor? 106 | -- or handle a mix of test and non-test parts? 107 | 108 | history :: Trie a -> History a 109 | history (Trie p f) = History step (p False) where 110 | step xs a = f a False seen xs 111 | -------------------------------------------------------------------------------- /src/version/Version.hs: -------------------------------------------------------------------------------- 1 | module Version 2 | ( version 3 | ) where 4 | 5 | import Data.List (intercalate) 6 | import Data.Version 7 | import qualified Paths_coda 8 | 9 | -- | Grab the version number from this project. 10 | version :: String 11 | version = intercalate "." $ show <$> tail (versionBranch Paths_coda.version) 12 | -------------------------------------------------------------------------------- /test/code/extension.test.ts: -------------------------------------------------------------------------------- 1 | import * as assert from 'assert'; 2 | import * as vscode from 'vscode'; 3 | import * as myExtension from '../../code/extension'; 4 | suite("extension tests", () => { 5 | test("missing", () => { 6 | assert.equal(-1, [1, 2, 3].indexOf(5)); 7 | assert.equal(-1, [1, 2, 3].indexOf(0)); 8 | }); 9 | }); 10 | -------------------------------------------------------------------------------- /test/code/index.ts: -------------------------------------------------------------------------------- 1 | let testRunner = require('vscode/lib/testrunner'); 2 | testRunner.configure({ ui: 'tdd', useColors: true }); 3 | module.exports = testRunner; 4 | -------------------------------------------------------------------------------- /test/data/request.golden: -------------------------------------------------------------------------------- 1 | Content-Length: 43 2 | 3 | {"jsonrpc":"2.0","id":1,"method":"request"} -------------------------------------------------------------------------------- /test/data/response.golden: -------------------------------------------------------------------------------- 1 | Content-Length: 38 2 | 3 | {"jsonrpc":"2.0","id":"id","result":2} -------------------------------------------------------------------------------- /tsconfig.json: -------------------------------------------------------------------------------- 1 | { 2 | "compilerOptions": { 3 | "target": "es6", 4 | "module": "commonjs", 5 | "strictNullChecks": true, 6 | "noImplicitAny": true, 7 | "lib": [ "es2016" ], 8 | "sourceMap": true, 9 | "outDir": "out", 10 | "rootDir": "." 11 | }, 12 | "include": [ 13 | "code/**/*", 14 | "test/code/**/*" 15 | ] 16 | } 17 | -------------------------------------------------------------------------------- /tslint.json: -------------------------------------------------------------------------------- 1 | { 2 | "rules": { 3 | "class-name": true, 4 | "comment-format": [ 5 | true, 6 | "check-space" 7 | ], 8 | "indent": [ 9 | true, 10 | "spaces", 11 | 2 12 | ], 13 | "no-duplicate-variable": true, 14 | "no-eval": true, 15 | "no-internal-module": true, 16 | "no-trailing-whitespace": true, 17 | "no-var-keyword": true, 18 | "one-line": [ 19 | true, 20 | "check-open-brace", 21 | "check-whitespace" 22 | ], 23 | "quotemark": [ 24 | true, 25 | "single" 26 | ], 27 | "semicolon": true, 28 | "triple-equals": [ 29 | true, 30 | "allow-null-check" 31 | ], 32 | "typedef-whitespace": [ 33 | true, 34 | { 35 | "call-signature": "nospace", 36 | "index-signature": "nospace", 37 | "parameter": "nospace", 38 | "property-declaration": "nospace", 39 | "variable-declaration": "nospace" 40 | } 41 | ], 42 | "variable-name": [ 43 | true, 44 | "ban-keywords" 45 | ], 46 | "whitespace": [ 47 | true, 48 | "check-branch", 49 | "check-decl", 50 | "check-operator", 51 | "check-type" 52 | ] 53 | } 54 | } 55 | -------------------------------------------------------------------------------- /wip/bdd/Data/Bimap.hs: -------------------------------------------------------------------------------- 1 | -- | Based on "Implementing Explicit and Finding Implicit Sharing in Embedded DSLs" 2 | -- by Oleg Kiselyov, then perverted for a completely antithetical purpose by 3 | -- the BDD module 4 | module Data.Bimap 5 | ( Bimap(..) 6 | , Id 7 | , lookupKey 8 | , lookupVal 9 | , insert 10 | , insertR 11 | , empty 12 | , size 13 | ) where 14 | 15 | import Data.Hashable 16 | import qualified Data.HashMap.Strict as HashMap 17 | import Data.HashMap.Strict (HashMap) 18 | import Data.List.Skew as Skew 19 | 20 | type Id = Int 21 | 22 | data Bimap a = Bimap !Id !(HashMap a Id) !(Skew a) 23 | 24 | lookupKey :: (Hashable a, Eq a) => a -> Bimap a -> Maybe Id 25 | lookupKey a (Bimap _ m _) = HashMap.lookup a m 26 | 27 | lookupVal :: Id -> Bimap a -> a 28 | lookupVal i (Bimap k _ n) = Skew.index n (k - i) 29 | 30 | -- for use with modify 31 | insert :: (Hashable a, Eq a) => a -> Bimap a -> (Id, Bimap a) 32 | insert a b@(Bimap i m n) = case HashMap.lookup a m of 33 | Nothing -> (i, Bimap (i+1) (HashMap.insert a i m) (Cons a n)) 34 | Just j -> (j, b) 35 | 36 | -- swapped for convenient use with atomicModifyIORef 37 | insertR :: (Hashable a, Eq a) => a -> Bimap a -> (Bimap a, Id) 38 | insertR a b@(Bimap i m n) = case HashMap.lookup a m of 39 | Nothing -> (Bimap (i+1) (HashMap.insert a i m) (Cons a n), i) 40 | Just j -> (b, j) 41 | 42 | -- node ids start at 1, so we can use negated node ids 43 | empty :: Bimap a 44 | empty = Bimap 1 HashMap.empty Skew.Nil 45 | 46 | size :: Bimap a -> Int 47 | size (Bimap i _ _) = i 48 | -------------------------------------------------------------------------------- /wip/bdd/Data/List/Skew.hs: -------------------------------------------------------------------------------- 1 | {-# language BangPatterns #-} 2 | {-# language DeriveTraversable #-} 3 | {-# language TypeFamilies #-} 4 | {-# language FlexibleInstances #-} 5 | {-# language MultiParamTypeClasses #-} 6 | {-# language PatternSynonyms #-} 7 | {-# language ViewPatterns #-} 8 | module Data.List.Skew 9 | ( Skew(Cons, Nil) 10 | , uncons 11 | , index 12 | ) where 13 | 14 | import qualified Data.List as List 15 | import GHC.Exts as Exts 16 | 17 | instance Exts.IsList (Skew a) where 18 | type Item (Skew a) = a 19 | fromList = foldr cons Nil 20 | toList = List.unfoldr uncons 21 | 22 | -- | Skew binary random access list a la Okasaki 23 | data Skew a = Skew !Int !(Tree a) !(Skew a) | Nil 24 | deriving (Eq,Ord,Show,Functor,Traversable) 25 | 26 | {-# complete Cons, Nil #-} 27 | {-# complete Skew, Nil #-} 28 | 29 | -- /O(1)/ 30 | pattern Cons :: a -> Skew a -> Skew a 31 | pattern Cons x xs <- (uncons -> Just (x, xs)) where 32 | Cons x xs = cons x xs 33 | 34 | instance Foldable Skew where 35 | length (Skew n _ xs) = n + length xs 36 | length Nil = 0 37 | foldMap _ Nil = mempty 38 | foldMap f (Skew _ xs ys) = foldMap f xs `mappend` foldMap f ys 39 | null Nil = True 40 | null _ = False 41 | 42 | data Tree a = Bin !Int a !(Tree a) !(Tree a) | Tip a 43 | deriving (Eq,Ord,Show,Functor, Traversable) 44 | 45 | instance Foldable Tree where 46 | length (Bin n _ _ _) = n 47 | length (Tip _) = 1 48 | null _ = False 49 | foldMap f (Tip a) = f a 50 | foldMap f (Bin _ a l r) = f a `mappend` foldMap f l `mappend` foldMap f r 51 | 52 | cons :: a -> Skew a -> Skew a 53 | cons a (Skew n xs (Skew _ ys zs)) | n == n = Skew (2*n+1) (Bin n a xs ys) zs 54 | cons a ys = Skew 1 (Tip a) ys 55 | 56 | -- /O(1)/ 57 | uncons :: Skew a -> Maybe (a, Skew a) 58 | uncons (Skew _ (Bin s a l r) ys) = Just (a, Skew s l (Skew s r ys)) 59 | uncons (Skew _ (Tip a) ys) = Just (a, ys) 60 | uncons Nil = Nothing 61 | 62 | -- /O(log n)/ 63 | index :: Skew a -> Int -> a 64 | index (Skew n xs ys) !i0 65 | | i0 >= n = index ys (i0 - n) 66 | | otherwise = go i0 xs 67 | where 68 | go _ (Tip a) = a 69 | go i (Bin s a l r) 70 | | i == 0 = a 71 | | i <= s = go (i-1) l 72 | | otherwise = go (i-1-s) r 73 | index Nil _ = error "Skew.index: out of bounds" 74 | -------------------------------------------------------------------------------- /wip/bdd/Ersatz/Solver/BDD.hs: -------------------------------------------------------------------------------- 1 | {-# language ScopedTypeVariables #-} 2 | {-# language FlexibleContexts #-} 3 | {-# language BangPatterns #-} 4 | {-# language Strict #-} 5 | module Ersatz.Solver.BDD where 6 | 7 | import Control.Applicative 8 | import Data.Bits 9 | import Data.BDD as BDD 10 | import Data.IntMap as IntMap 11 | import Data.IntSet as IntSet 12 | import Data.Proxy 13 | import Ersatz.Problem 14 | import Ersatz.Solution 15 | 16 | literal :: Cached s => Int -> BDD s 17 | literal 1 = One 18 | literal (-1) = Zero 19 | literal i = polarize i $ var (abs i) 20 | 21 | -- use a more deliberate bdd construction for the clauses that constructs from the bottom up 22 | clause :: Cached s => IntSet -> BDD s 23 | -- clause = IntSet.foldr (\a r -> literal a `BDD.or` r) Zero 24 | clause is = case splitMember 1 is of 25 | (l,t,r) 26 | | t -> One -- True is a member of the clause 27 | | otherwise -> start Zero (IntSet.toAscList $ fst $ IntSet.split (-1) l) (IntSet.toDescList r) 28 | where 29 | start acc [] ys = posi acc ys 30 | start acc xs [] = negi acc xs 31 | start acc (x:xs) (y:ys) = go acc (negate x) xs y ys 32 | posi !acc [] = acc 33 | posi acc (y:ys) = posi (BDD y acc One) ys 34 | negi !acc [] = acc 35 | negi acc (x:xs) = negi (BDD (negate x) One acc) xs 36 | go !acc !x xs !y ys = case compare x y of 37 | GT | acc' <- BDD x One acc -> case xs of 38 | [] -> posi (BDD y acc' One) ys 39 | x':xs' -> go acc' (negate x') xs' y ys 40 | EQ -> One -- x \/ ~x => this clause is always true 41 | LT | acc' <- BDD y acc One -> case ys of 42 | [] -> negi (BDD x One acc') xs 43 | y':ys' -> go acc' x xs y' ys' 44 | 45 | robdd :: Monad m => Solver SAT m 46 | robdd problem = pure $ reifyCache $ \(Proxy :: Proxy s) -> 47 | let solve = Prelude.foldr (\a r -> clause a .&. r) One 48 | 49 | result :: BDD s 50 | result = solve (dimacsClauses problem) 51 | 52 | present One = Just IntMap.empty 53 | present Zero = Nothing 54 | present (BDD v l r) = IntMap.insert v False <$> present l 55 | <|> IntMap.insert v True <$> present r 56 | in case present result of 57 | Nothing -> (Unsatisfied, IntMap.empty) 58 | Just s -> (Satisfied, s) 59 | -------------------------------------------------------------------------------- /wip/bdd/TODO.txt: -------------------------------------------------------------------------------- 1 | thoughts: 2 | 3 | * build the entire cache as an mvar pointing to a bytearray rather than reference external memory 4 | * build a hash table and use it directly, w/ linear probing and sth? 5 | * easy gc due to unidirectional heap, roots maintained externally by haskell 6 | * can we get better sharing by storing delta vars? this way shifting an entire bdd would only move a root! 7 | -- we could also get away with much smaller var sizes as big nodes can be represented by "illegal" 255 -> (y,y) nodes 8 | * spmd bdd evaluation 9 | * compressed obdds can be represented in 1-2 bits per node for offline storage 10 | * aligned-nybble-tries would give us better branching factor and locality 11 | * it also means testing nybble-windows against neighboring nybble windows, rather than tiny 2-variable windows for faster reordering 12 | * build variable order online as variables get inserted? order maintenance problem? 13 | and when putting in a new var it goes at the top unless we have a constraint ordering the two. 14 | 15 | SPMD based BDD evaluator? compute ite in parallel? recursively add shannon decompositions to current set. 16 | SPMBDD -- shannon decomposition on nybbles would give a good fill of a simd unit 17 | 18 | 16, 16-bit node ids fit into a 256 bit simd lane 19 | 20 | -------------------------------------------------------------------------------- /wip/bdd/bdd.cabal: -------------------------------------------------------------------------------- 1 | name: bdd 2 | category: Language 3 | version: 0.0.1 4 | license: BSD2 5 | cabal-version: 2 6 | author: Edward A. Kmett 7 | maintainer: Edward A. Kmett 8 | stability: provisional 9 | homepage: http://github.com/ekmett/coda/ 10 | bug-reports: http://github.com/ekmett/coda/issues 11 | copyright: Copyright (C) 2017 Edward A. Kmett 12 | build-type: Simple 13 | synopsis: ROBDDs 14 | description: Reduced ordered binary decision diagrams with optimized negation 15 | 16 | source-repository head 17 | type: git 18 | location: git://github.com/ekmett/coda.git 19 | 20 | flag examples 21 | description: Build examples 22 | default: True 23 | manual: True 24 | 25 | library 26 | default-language: Haskell2010 27 | ghc-options: -Wall 28 | 29 | exposed-modules: 30 | Data.BDD 31 | Ersatz.Solver.BDD 32 | 33 | other-modules: 34 | Data.Bimap 35 | Data.List.Skew 36 | 37 | build-depends: 38 | base >= 4.10 && < 5, 39 | containers ^>= 0.5, 40 | ersatz >= 0.4 && < 1, 41 | hashable ^>= 1.2.6, 42 | lens, 43 | reflection >= 2.1 && < 3, 44 | transformers ^>= 0.5, 45 | unordered-containers >= 0.2.6 && < 3 46 | 47 | test-suite factor 48 | type: exitcode-stdio-1.0 49 | default-language: Haskell2010 50 | ghc-options: -Wall -rtsopts 51 | hs-source-dirs: examples 52 | main-is: factor.hs 53 | if !flag(examples) 54 | buildable: False 55 | else 56 | build-depends: 57 | base, 58 | bdd, 59 | ersatz, 60 | mtl 61 | 62 | test-suite fish 63 | type: exitcode-stdio-1.0 64 | default-language: Haskell2010 65 | ghc-options: -Wall -rtsopts 66 | hs-source-dirs: examples 67 | main-is: fish.hs 68 | if !flag(examples) 69 | buildable: False 70 | else 71 | build-depends: 72 | base, 73 | bdd, 74 | containers, 75 | ersatz, 76 | mtl 77 | 78 | test-suite sudoku 79 | type: exitcode-stdio-1.0 80 | default-language: Haskell2010 81 | main-is: Main.hs 82 | other-modules: Sudoku.Cell Sudoku.Problem 83 | ghc-options: -Wall -rtsopts 84 | hs-source-dirs: examples/sudoku 85 | if !flag(examples) 86 | buildable: False 87 | else 88 | build-depends: 89 | array, 90 | base < 5, 91 | bdd, 92 | ersatz, 93 | mtl 94 | -------------------------------------------------------------------------------- /wip/bdd/dist/cabal-config-flags: -------------------------------------------------------------------------------- 1 | --verbose=1--builddir=dist--ghc--prefix=/Users/ekmett/Library/Haskell--libdir=$prefix/$compiler-$arch/lib--libsubdir=$pkgid--datasubdir=$compiler-$arch/$pkgid--docdir=$prefix/$compiler-$arch/lib/$pkgid/doc--disable-library-profiling--disable-optimization--user--extra-prog-path=/Users/ekmett/Library/Haskell/bin--solver=modular -------------------------------------------------------------------------------- /wip/bdd/examples/factor.hs: -------------------------------------------------------------------------------- 1 | import Ersatz 2 | import Ersatz.Solver.BDD 3 | import Control.Monad 4 | import Control.Monad.State 5 | 6 | problem :: (MonadState s m, HasSAT s) => m (Bits, Bits, Bits) 7 | problem = do 8 | a <- liftM Bits (replicateM 5 exists) 9 | b <- liftM Bits (replicateM 5 exists) 10 | let c = a * b 11 | assert (a /== encode 1) 12 | assert (b /== encode 1) 13 | assert (c === encode 143) 14 | return (a,b,c) 15 | 16 | main :: IO () 17 | main = do 18 | putStrLn "Solution:" 19 | (Satisfied, Just (a,b,c)) <- solveWith robdd problem 20 | putStrLn (show a ++ " * " ++ show b ++ " = " ++ show c) 21 | -------------------------------------------------------------------------------- /wip/bdd/examples/sudoku/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main (main) where 3 | 4 | import Prelude hiding ((&&), (||), not, and, or, all, any) 5 | 6 | #if __GLASGOW_HASKELL__ < 710 7 | import Control.Applicative 8 | #endif 9 | import Control.Monad 10 | import Data.Array (Array, (!)) 11 | import qualified Data.Array as Array 12 | import Data.List 13 | import Data.Word 14 | import Ersatz 15 | import Ersatz.Solver.BDD 16 | import Sudoku.Problem 17 | 18 | main :: IO () 19 | main = do 20 | putStrLn "Problem:" 21 | putStr (render initValues) 22 | 23 | putStrLn "Solution:" 24 | (res, msol) <- solveWith robdd (problem initValues) 25 | when (res /= Satisfied) (fail (show res)) 26 | case msol of 27 | Just sol -> putStr (render sol) 28 | _ -> fail ("sol was " ++ show msol) 29 | 30 | initValues :: Array (Word8,Word8) Word8 31 | initValues = 32 | -- From https://en.wikipedia.org/w/index.php?title=Sudoku&oldid=543290082 33 | Array.listArray range 34 | [ 5, 3, 0, 0, 7, 0, 0, 0, 0 35 | , 6, 0, 0, 1, 9, 5, 0, 0, 0 36 | , 0, 9, 8, 0, 0, 0, 0, 6, 0 37 | , 8, 0, 0, 0, 6, 0, 0, 0, 3 38 | , 4, 0, 0, 8, 0, 3, 0, 0, 1 39 | , 7, 0, 0, 0, 2, 0, 0, 0, 6 40 | , 0, 6, 0, 0, 0, 0, 2, 8, 0 41 | , 0, 0, 0, 4, 1, 9, 0, 0, 5 42 | , 0, 0, 0, 0, 8, 0, 0, 7, 9 43 | ] 44 | 45 | render :: Array (Word8,Word8) Word8 -> String 46 | render sol = unlines . renderGroups top divider bottom 47 | $ map (renderLine sol) [0..8] 48 | where 49 | top = bar "┌" "───────" "┬" "┐" 50 | divider = bar "├" "───────" "┼" "┤" 51 | bottom = bar "└" "───────" "┴" "┘" 52 | 53 | bar begin fill middle end = 54 | begin ++ intercalate middle (replicate 3 fill) ++ end 55 | 56 | renderLine :: Array (Word8,Word8) Word8 -> Word8 -> String 57 | renderLine sol y = unwords . renderGroups "│" "│" "│" 58 | $ map (\x -> showN (sol ! (y,x))) [0..8] 59 | where 60 | showN n | 1 <= n && n <= 9 = show n 61 | | otherwise = " " 62 | 63 | renderGroups :: a -> a -> a -> [a] -> [a] 64 | renderGroups begin middle end values = 65 | [begin] ++ intercalate [middle] (chunks 3 values) ++ [end] 66 | where 67 | chunks n = unfoldr $ \xs -> splitAt n xs <$ guard (not (null xs)) 68 | -------------------------------------------------------------------------------- /wip/bdd/examples/sudoku/Sudoku/Cell.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | 5 | module Sudoku.Cell (Cell(..)) where 6 | 7 | import Prelude hiding ((&&), (||), not, and, or, all, any) 8 | 9 | import Data.Typeable (Typeable) 10 | import Data.Word 11 | import Ersatz 12 | import GHC.Generics 13 | 14 | newtype Cell = Cell Bit4 15 | deriving (Show, Typeable, Generic) 16 | 17 | instance Boolean Cell 18 | instance Variable Cell 19 | instance Equatable Cell 20 | 21 | instance Codec Cell where 22 | type Decoded Cell = Word8 23 | decode s (Cell b) = decode s b 24 | encode n | 1 <= n && n <= 9 = Cell (encode n) 25 | | otherwise = error ("Cell encode: invalid value " ++ show n) 26 | -------------------------------------------------------------------------------- /wip/bdd/examples/sudoku/Sudoku/Problem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | module Sudoku.Problem (problem, range) where 4 | 5 | import Prelude hiding ((&&), (||), not, and, or, all, any) 6 | 7 | #if __GLASGOW_HASKELL__ < 710 8 | import Control.Applicative 9 | #endif 10 | import Control.Monad.Reader 11 | import Control.Monad.State 12 | import Data.Array (Array, (!)) 13 | import qualified Data.Array as Array 14 | import Data.Word 15 | import Ersatz 16 | 17 | import Sudoku.Cell 18 | 19 | type Index = (Word8,Word8) 20 | 21 | type Grid = Array Index Cell 22 | 23 | data Env = Env { envCellArray :: Grid -- ^ The puzzle. 24 | , envValues :: [Cell] -- ^ The possible values for any cell. 25 | } 26 | deriving Show 27 | 28 | problem :: (Applicative m, MonadState s m, HasSAT s) 29 | => Array Index Word8 -> m Grid 30 | problem initValues = do 31 | cellArray <- Array.listArray range 32 | <$> replicateM (Array.rangeSize range) exists 33 | 34 | runReaderT problem' $ Env cellArray (map encode [1..9]) 35 | 36 | -- Assert all initial values. 37 | forM_ (Array.assocs initValues) $ \(idx, val) -> 38 | when (1 <= val && val <= 9) $ 39 | assert $ (cellArray ! idx) === encode val 40 | 41 | return cellArray 42 | 43 | problem' :: (MonadState s m, HasSAT s) => ReaderT Env m () 44 | problem' = do 45 | legalValues 46 | mapM_ allDifferent (subsquares ++ horizontal ++ vertical) 47 | 48 | -- | Assert that each cell must have one of the legal values. 49 | legalValues :: (MonadState s m, HasSAT s) => ReaderT Env m () 50 | legalValues = mapM_ legalValue . Array.elems =<< asks envCellArray 51 | where 52 | legalValue cell = do 53 | values <- asks envValues 54 | assert $ any (cell ===) values 55 | 56 | -- | Assert that each cell in a group must have a different value. 57 | allDifferent :: (MonadState s m, HasSAT s) 58 | => [(Word8,Word8)] -> ReaderT Env m () 59 | allDifferent indices = do 60 | cellArray <- asks envCellArray 61 | let pairs = [ (cellArray ! a, cellArray ! b) 62 | | a <- indices, b <- indices, a /= b 63 | ] 64 | forM_ pairs $ \(cellA, cellB) -> assert (cellA /== cellB) 65 | 66 | -- | The valid index range for the grid. 67 | range :: (Index,Index) 68 | range = ((0,0),(8,8)) 69 | 70 | subsquares, horizontal, vertical :: [[Index]] 71 | 72 | -- | The index group for each subsquare. 73 | subsquares = do 74 | sqY <- [0..2] 75 | sqX <- [0..2] 76 | let top = 3*sqY 77 | left = 3*sqX 78 | return [ (y,x) | y <- [top..top+2], x <- [left..left+2] ] 79 | 80 | -- | The index group for each line. 81 | horizontal = do 82 | line <- [0..8] 83 | return [ (line,x) | x <- [0..8] ] 84 | 85 | -- | The index group for each column. 86 | vertical = do 87 | column <- [0..8] 88 | return [ (y,column) | y <- [0..8] ] 89 | --------------------------------------------------------------------------------