Explorar el Código

repl with repline

main
soupi hace 1 año
padre
commit
b6fd8eb6c6
Se han modificado 6 ficheros con 250 adiciones y 9 borrados
  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 Ver fichero

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

*.cabal
.history

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


+ 123
- 1
app/Main.hs Ver fichero

@@ -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 Ver fichero

@@ -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 Ver fichero

@@ -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 Ver fichero

@@ -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 Ver fichero

@@ -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: {}



Cargando…
Cancelar
Guardar