soupi 1 год назад
Родитель
Сommit
b6fd8eb6c6
6 измененных файлов: 250 добавлений и 9 удалений
  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 Просмотреть файл

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

*.cabal
.history

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


+ 123
- 1
app/Main.hs Просмотреть файл

@@ -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 Просмотреть файл

@@ -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 Просмотреть файл

@@ -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 Просмотреть файл

@@ -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 Просмотреть файл

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



Загрузка…
Отмена
Сохранить