Sfoglia il codice sorgente

repl with repline

main
soupi 1 anno fa
parent
commit
b6fd8eb6c6
6 ha cambiato i file con 250 aggiunte e 9 eliminazioni
  1. +1
    -1
      .gitignore
  2. +123
    -1
      app/Main.hs
  3. +118
    -0
      logi.cabal
  4. +3
    -5
      package.yaml
  5. +2
    -1
      src/Language/Logi/Pretty.hs
  6. +3
    -1
      stack.yaml

+ 1
- 1
.gitignore Vedi File

@@ -1,6 +1,6 @@
# Created by https://www.gitignore.io

*.cabal
.history

### vim ###
[._]*.s[a-w][a-z]


+ 123
- 1
app/Main.hs Vedi File

@@ -1,6 +1,128 @@
module Main where

import Relude
import Relude.Extra.Lens
import System.Random
import qualified Data.Text as T
import qualified Data.Map as M
import Control.Exception
import Data.Serialize (encode, decode)
import System.Console.Repline

import Language.Logi

type Repl a = HaskelineT (StateT Ctx IO) a

-- Evaluation : handle each line user inputs
cmd :: Text -> Repl ()
cmd input = do
Ctx knowledge seed <- get
case exec seed knowledge "repl" input of
Left err -> do
putTextLn $ ppErr err
Right (results, ctx') -> do
(putTextLn . ppToText . ppResults) results
put ctx'

trim :: Text -> Text
trim = T.dropWhile (==' ') . T.reverse . T.dropWhile (==' ') . T.reverse

-- Commands
help :: [Text] -> Repl ()
help args = liftIO $ print $ "Help: " ++ show args

load :: Text -> Repl ()
load args = do
let
action = do
decode <$> readFileBS (toString $ trim args)
result <- liftIO $
catch action $ \(SomeException e) -> pure (Left $ show e)
case result of
Right knowledge' -> do
modify $ set ctxKnowledge knowledge'
putTextLn "done."
Left err ->
putStrLn err

save :: Text -> Repl ()
save args = do
knowledge <- gets _ctxKnowledge
let
action = do
writeFileBS (toString args) (encode knowledge)
putTextLn "done."
liftIO $
catch action $ \(SomeException e) -> putTextLn (show e)

-- Options
opts :: [(Text, Text -> Repl ())]
opts =
let
fullopts =
[ ("help", help . words) -- :help
, ("load", load) -- :load
, ("save", save) -- :load
, ("quit", const (final *> abort)) -- :load
]
in
fullopts <> map (first (T.take 1)) fullopts

-- Tab Completion: return a completion for partial words entered
completer :: MonadState Ctx m => WordCompleter m
completer n = do
names <- gets $ map toString . M.keys . view (ctxKnowledge . rules)
return $ filter (isPrefixOf n) names

-- Completer
defaultMatcher :: (MonadState Ctx m, MonadIO m) => [(String, CompletionFunc m)]
defaultMatcher =
-- Commands
[ (":load", fileCompleter)
, (":l", fileCompleter)
, (":save", fileCompleter)
, (":s", fileCompleter)
]

byWord :: Monad m => WordCompleter m
byWord (toText -> n) = do
let names = fmap ((":" <>) . fst) opts
return $ fmap toString $ filter (T.isPrefixOf n) names

-- Initialiser function
ini :: Repl ()
ini = liftIO $ putTextLn ">>> Welcome to logi-repl."

-- Finaliser function
final :: Repl ExitDecision
final = do
liftIO $ putTextLn "Goodbye!"
return Exit

customBanner :: MultiLine -> Repl String
customBanner = \case
SingleLine -> pure "> "
MultiLine -> pure "| "

repl :: IO ()
repl = do
seed <- getStdGen
let
context = Ctx defaultKnowledge seed
flip evalStateT context $ evalReplOpts $
ReplOpts
{ banner = customBanner
, command = cmd . toText
, options = fmap (\(a, b) -> (toString a, b . toText)) opts
, prefix = Just ':'
, multilineCommand = Nothing
, tabComplete = Combine
(Word0 completer)
(Prefix (wordCompleter byWord) defaultMatcher)
, initialiser = ini
, finaliser = final
}

main :: IO ()
main = putTextLn "hi"
main = repl

+ 118
- 0
logi.cabal Vedi File

@@ -0,0 +1,118 @@
cabal-version: 1.12

-- This file has been generated from package.yaml by hpack version 0.33.0.
--
-- see: https://github.com/sol/hpack
--
-- hash: 18f5208c19f9872da2b0b0c1abe9dd0f71d67ccc6d5003d1185eccec8706ef97

name: logi
version: 0.1.0
author: Gil Mizrahi
maintainer: gilmi@posteo.net
copyright: 2020 Gil Mizrahi
license: Apache-2.0
license-file: LICENSE
build-type: Simple
extra-source-files:
README.org

library
exposed-modules:
Language.Logi
Language.Logi.Ast
Language.Logi.EDSL
Language.Logi.Error
Language.Logi.Interpreter
Language.Logi.Parser
Language.Logi.Pretty
Language.Logi.Run
other-modules:
Paths_logi
hs-source-dirs:
src
default-extensions: NoImplicitPrelude BangPatterns ConstraintKinds DataKinds DeriveFunctor DeriveFoldable DeriveTraversable DeriveDataTypeable DeriveGeneric DeriveAnyClass EmptyDataDecls FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiWayIf MultiParamTypeClasses FunctionalDependencies TypeSynonymInstances PatternGuards PatternSynonyms RankNTypes RecordWildCards NamedFieldPuns ScopedTypeVariables TupleSections ViewPatterns TypeApplications OverloadedStrings QuasiQuotes
build-depends:
base
, bifunctors
, bytestring
, cereal
, containers
, deepseq
, groom
, hspec
, lens
, megaparsec
, mtl
, prettyprinter
, random
, relude
, text
, transformers
, uniplate
, vector
default-language: Haskell2010

executable logi-repl
main-is: Main.hs
other-modules:
Paths_logi
hs-source-dirs:
app
default-extensions: NoImplicitPrelude BangPatterns ConstraintKinds DataKinds DeriveFunctor DeriveFoldable DeriveTraversable DeriveDataTypeable DeriveGeneric DeriveAnyClass EmptyDataDecls FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiWayIf MultiParamTypeClasses FunctionalDependencies TypeSynonymInstances PatternGuards PatternSynonyms RankNTypes RecordWildCards NamedFieldPuns ScopedTypeVariables TupleSections ViewPatterns TypeApplications OverloadedStrings QuasiQuotes
ghc-options: -Wall -fno-warn-missing-signatures -O2 -rtsopts -funfolding-use-threshold=16 -optc-O3
build-depends:
base
, bifunctors
, bytestring
, cereal
, containers
, deepseq
, groom
, hspec
, lens
, logi
, megaparsec
, mtl
, optparse-generic
, prettyprinter
, random
, relude
, repline
, text
, transformers
, uniplate
, vector
default-language: Haskell2010

test-suite test
type: exitcode-stdio-1.0
main-is: Test.hs
other-modules:
Run
Paths_logi
hs-source-dirs:
test
default-extensions: NoImplicitPrelude BangPatterns ConstraintKinds DataKinds DeriveFunctor DeriveFoldable DeriveTraversable DeriveDataTypeable DeriveGeneric DeriveAnyClass EmptyDataDecls FlexibleContexts FlexibleInstances KindSignatures LambdaCase MultiWayIf MultiParamTypeClasses FunctionalDependencies TypeSynonymInstances PatternGuards PatternSynonyms RankNTypes RecordWildCards NamedFieldPuns ScopedTypeVariables TupleSections ViewPatterns TypeApplications OverloadedStrings QuasiQuotes
ghc-options: -Wall -fno-warn-missing-signatures -O2 -rtsopts -funfolding-use-threshold=16 -optc-O3 -threaded
build-depends:
base
, bifunctors
, bytestring
, cereal
, containers
, deepseq
, groom
, hspec
, lens
, logi
, megaparsec
, mtl
, prettyprinter
, random
, relude
, text
, transformers
, uniplate
, vector
default-language: Haskell2010

+ 3
- 5
package.yaml Vedi File

@@ -30,7 +30,6 @@ dependencies:
- hspec



library:
source-dirs: src
default-extensions:
@@ -73,14 +72,13 @@ executables:
dependencies:
- relude
- optparse-generic
- unix
- async
- logi
- repline

ghc-options:
- -Wall
- -fno-warn-missing-signatures
- -Werror
# - -Werror
- -O2
- -rtsopts
- -funfolding-use-threshold=16
@@ -166,4 +164,4 @@ tests:
- ViewPatterns
- TypeApplications
- OverloadedStrings
- QuasiQuotes
- QuasiQuotes

+ 2
- 1
src/Language/Logi/Pretty.hs Vedi File

@@ -16,7 +16,8 @@ pptrace txt x = trace (toString $ txt <> ": " <> ppToText (pretty x)) x
{-# WARNING pptrace "'pptrace' remains in code" #-}

ppToText :: Doc ann -> Text
ppToText = renderStrict . layoutSmart defaultLayoutOptions
ppToText =
renderStrict . layoutSmart LayoutOptions{layoutPageWidth = AvailablePerLine 120 1}

ppVar :: Var -> Doc ann
ppVar (Var var) = pretty var


+ 3
- 1
stack.yaml Vedi File

@@ -3,7 +3,9 @@ resolver: lts-16.15
packages:
- '.'

extra-deps: []
extra-deps:
- haskeline-0.8.1.0@sha256:6a6158c90b929ce7aa5331ff5e9819aa32c7df8f4a7ba324b3cc055ee96b48cb,5818
- repline-0.4.0.0@sha256:3324479e497d27c40c3d4762bffc52058f9921621d20d2947dcf9a554b94cd0d,2253

flags: {}



Loading…
Annulla
Salva