diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,50 +1,31 @@ -[![CircleCI](https://circleci.com/gh/pdlla/potato-flow.svg?style=svg)](https://circleci.com/gh/pdlla/potato-flow) - -# potato-illustrator -`potato-illustrator` is a mono-space text flow-chart editor written in Haskell. It is currently a work in progress and an ALPHA release should be available soon. +# tinytools +`tinytools` is a mono-space unicode flow-chart editor written in Haskell. # architecture -`potato-illustrator` is written using [reflex](https://github.com/reflex-frp/reflex) and follows a strict MVC architecture. This repository contains the platform-independent model and controller. -The View is connected to the reflex interface defined by `GoatWidget`. +`tinytools` follows a strict MVC architecture. This repository contains the platform-independent model and controller. +The view/controller is connected to the model using a [reflex](https://github.com/reflex-frp/reflex) interface defined by `GoatWidget`. -[potato-illustrator-vty](https://github.com/pdlla/potato-illustrator-vty) is currently the only view implementation. It is written in [reflex-vty](https://github.com/reflex-frp/reflex-vty) and runs in a terminal yay. Please see [potato-illustrator-vty](https://github.com/pdlla/potato-illustrator-vty) if you'd like to try it out. +[tinytools-vty](https://github.com/pdlla/tinytools-vty) is currently the only view implementation. It is written in [reflex-vty](https://github.com/reflex-frp/reflex-vty) and runs in a terminal yay. Please see [tinytools-vty](https://github.com/pdlla/tinytools-vty) if you'd like to try it out. # features (completed) - sophisticated hierarchical layer system - transactional operations and change history -- several configurable primitives including boxes, lines and text boxes +- several highly configurable primitives including boxes, lines and text boxes +- basic document save/load/export functionality # roadmap -## alpha -- save/load/export interface -- multi-segment line input -- free form text-area input - ## v1 -- UNICODE wide character support +- UNICODE wide character support (currently blocked by issues in TextZipper) - UNICODE glyph widget ## v2 -- attached line support - multi-document support - refactor handle non-linear action do/undo operations in preparation for multi-user mode ## v3 -- graphene clusters support +- grapheme clusters support (blocked by terminal support which is currently extremely inconsistent or non-existent) - multi-user mode - ordering service interface - basic single client authoritative implementation of ordering service interface (for now) -- scripting - - -# Contribution Guide - -Help wanted! I will of course review any PR. For large or small ideas, it would be best to drop me an email first at chippermonky at gmail dot com - -Below are a list of tasks that I think would be extra good projects to work on - -- CI scripts for creating binary releases -- UNICODE wide character support -- add text selection support to current `TextZipper` implementation -- refactoring πŸ˜‘ +- scriptable command interface diff --git a/src/Potato/Data/Text/Unicode.hs b/src/Potato/Data/Text/Unicode.hs --- a/src/Potato/Data/Text/Unicode.hs +++ b/src/Potato/Data/Text/Unicode.hs @@ -3,26 +3,28 @@ import Prelude -import Graphics.Text.Width (wcwidth) +import Graphics.Text.Width (wcwidth) -import Data.Int -import qualified Data.Text.ICU as ICU -import qualified Data.Text as T -import Data.Text (Text) +import Data.Int +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.ICU as ICU import qualified Potato.Data.Text.Zipper as TZ + + -- NOTE this function won't work as expected until you've loaded a termal char width file via vty! getCharWidth :: Char -> Int8 getCharWidth = fromIntegral . TZ.charWidth removeWideChars :: Text -> Text -removeWideChars = T.filter (\c -> getCharWidth c <= 1) +removeWideChars = T.filter (\c -> getCharWidth c <= 1) internal_getCharacterBreaks :: Text -> [ICU.Break ()] -internal_getCharacterBreaks input = r where - breaker = ICU.breakCharacter ICU.Current +internal_getCharacterBreaks input = r where + breaker = ICU.breakCharacter ICU.Current r = ICU.breaks breaker input zwidge :: Char @@ -32,20 +34,20 @@ isSingleGraphemeCluster :: Text -> Bool isSingleGraphemeCluster input = r where tbreaks = internal_getCharacterBreaks input - r = case tbreaks of + r = case tbreaks of -- no characters, not a grapheme cluster - [] -> False + [] -> False -- only one break, it's a grapheme cluster if it has more than one unicode char in it (b:[]) -> T.length (ICU.brkBreak b) > 1 -- more than one character break - _ -> False + _ -> False -- | True if the last character in the text is a single grapheme cluster, False otherwise endsInGraphemeCluster :: Text -> Bool endsInGraphemeCluster input = r where tbreaks' = internal_getCharacterBreaks input - gotoend tbreaks = case tbreaks of - [] -> False + gotoend tbreaks = case tbreaks of + [] -> False (b:[]) -> isSingleGraphemeCluster (ICU.brkBreak b) (_:bs) -> gotoend bs r = gotoend tbreaks' @@ -58,10 +60,24 @@ -- if there is more than one character in the break then it must have been a grapheme cluster -- so just use the first character fmapfn b = case T.uncons (ICU.brkBreak b) of - Nothing -> "" + Nothing -> "" Just (c, _) -> T.singleton c r = mconcat $ fmap fmapfn tbreaks -- | True if the input text contains a grapheme cluster containsGraphemeCluster :: Text -> Bool containsGraphemeCluster input = removeGraphemeCluster input /= input + + + +-- πŸ€– isn't correct, misses emojis :() +{- +getCharWidth :: Char -> Int8 +getCharWidth c + | isControl c || c == '\t' = 0 + | w == 0x0 || w > 0x10ffff = 1 + | w >= 0x1100 && (w <= 0x115f || w == 0x2329 || w == 0x232a || (w >= 0x2e80 && w <= 0xa4cf && w /= 0x303f) || (w >= 0xac00 && w <= 0xd7a3) || (w >= 0xf900 && w <= 0xfaff) || (w >= 0xfe10 && w <= 0xfe19) || (w >= 0xfe30 && w <= 0xfe6f) || (w >= 0xff00 && w <= 0xff60) || (w >= 0xffe0 && w <= 0xffe6) || (w >= 0x20000 && w <= 0x2fffd) || (w >= 0x30000 && w <= 0x3fffd)) = 2 + | otherwise = 1 + where + w = ord c +-} diff --git a/src/Potato/Flow.hs b/src/Potato/Flow.hs --- a/src/Potato/Flow.hs +++ b/src/Potato/Flow.hs diff --git a/src/Potato/Flow/Controller/Types.hs b/src/Potato/Flow/Controller/Types.hs --- a/src/Potato/Flow/Controller/Types.hs +++ b/src/Potato/Flow/Controller/Types.hs @@ -29,8 +29,10 @@ import Data.Default import qualified Data.IntMap as IM import qualified Text.Show +import Data.Binary + -- someday it would be nice to support graphene clusters and RTL 😭 data UnicodeWidthFn = UnicodeWidthFn { unicodeWidth_wcwidth :: PChar -> Int @@ -112,7 +114,9 @@ instance FromJSON LayerMeta instance ToJSON LayerMeta instance NFData LayerMeta +instance Binary LayerMeta + -- Not sure which way I want to do it, so make it configurable for now. defaultFolderCollapseState :: Bool defaultFolderCollapseState = False @@ -150,6 +154,8 @@ instance FromJSON ControllerMeta instance ToJSON ControllerMeta +instance NFData ControllerMeta +instance Binary ControllerMeta emptyControllerMeta :: ControllerMeta emptyControllerMeta = ControllerMeta 0 IM.empty diff --git a/src/Potato/Flow/Serialization/Snake.hs b/src/Potato/Flow/Serialization/Snake.hs new file mode 100644 --- /dev/null +++ b/src/Potato/Flow/Serialization/Snake.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE RecordWildCards #-} + +module Potato.Flow.Serialization.Snake where + +import Relude + +import Potato.Flow.Types +import Potato.Flow.SElts +import Potato.Flow.Controller.Types + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encode.Pretty as PrettyAeson +import qualified Data.Binary as Binary +import qualified Data.ByteString.Lazy as LBS +import System.FilePath +import qualified Data.Text.Encoding as Text + + + +-- | list of all version supported +versions :: [Int] +versions = [1] + +-- | version of the current build +currentVersion :: Int +currentVersion = 1 + +data Snake = Snake { + _snake_version :: Int + -- string instead of enum type to ensure compatibility if new formats are ever added + -- currently supports "binary" and "json" + , _snake_format :: String + , _snake_data :: Text +} deriving (Eq, Generic, Show) + +instance Aeson.FromJSON Snake +instance Aeson.ToJSON Snake +instance Binary.Binary Snake +instance NFData Snake + +data SnakeFormat = SF_Json | SF_Binary + +serialize :: SnakeFormat -> (SPotatoFlow, ControllerMeta) -> LBS.ByteString +serialize f x = r where + (inner, format) = case f of + SF_Json -> (PrettyAeson.encodePretty x, "json") + SF_Binary -> (Binary.encode x, "binary") + outer = Snake { + _snake_version = currentVersion + , _snake_format = format + , _snake_data = Text.decodeUtf8 (LBS.toStrict inner) + } + r = PrettyAeson.encodePretty outer + +deserialize :: LBS.ByteString -> Either String (SPotatoFlow, ControllerMeta) +deserialize lbs = case Aeson.eitherDecode lbs of + Left e -> Left $ "failed to decode Snake with error " <> e + Right vso -> deserialize_internal vso + + +deserialize_internal :: Snake -> Either String (SPotatoFlow, ControllerMeta) +deserialize_internal Snake {..} = do + if _snake_version /= currentVersion + then Left $ "version mismatch, got: " <> show _snake_version <> " expected: " <> show currentVersion + else return () + case _snake_format of + "json" -> Aeson.eitherDecodeStrict (Text.encodeUtf8 _snake_data) + "binary" -> case Binary.decode (LBS.fromStrict $ Text.encodeUtf8 _snake_data) of + Just x -> Right x + Nothing -> Left "failed to decode binary" + x -> Left $ "unrecognized fromat" <> show x + + +decodeFile :: FilePath -> IO (Either String (SPotatoFlow, ControllerMeta)) +decodeFile fp = do + vsobs <- LBS.readFile fp + return $ deserialize vsobs + + +decodeFileMaybe :: FilePath -> IO (Maybe (SPotatoFlow, ControllerMeta)) +decodeFileMaybe fp = do + x <- decodeFile fp + case x of + Left _ -> return Nothing + Right x -> return (Just x) diff --git a/test/Potato/Data/Text/UnicodeSpec.hs b/test/Potato/Data/Text/UnicodeSpec.hs --- a/test/Potato/Data/Text/UnicodeSpec.hs +++ b/test/Potato/Data/Text/UnicodeSpec.hs @@ -36,4 +36,3 @@ it "containsGraphemeCluster" $ do containsGraphemeCluster "πŸ‘ŽπŸ‘ŽπŸ‘ŽπŸ‘ŽπŸ‘Ž" `shouldBe` False containsGraphemeCluster "πŸ‘ŽπŸ‘ŽπŸ‘ŽπŸΏπŸ‘ŽπŸ‘ŽπŸ‘Ž" `shouldBe` True - diff --git a/tinytools.cabal b/tinytools.cabal --- a/tinytools.cabal +++ b/tinytools.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: tinytools -version: 0.1.0.0 +version: 0.1.0.3 description: Please see the README on GitHub at homepage: https://github.com/pdlla/tinytools#readme bug-reports: https://github.com/pdlla/tinytools/issues @@ -73,6 +73,7 @@ Potato.Flow.RenderCache Potato.Flow.SEltMethods Potato.Flow.SElts + Potato.Flow.Serialization.Snake Potato.Flow.TestStates Potato.Flow.Types hs-source-dirs: @@ -117,6 +118,7 @@ build-depends: MonadRandom , aeson + , aeson-pretty , base >=4.7 && <5 , bimap , binary @@ -151,9 +153,10 @@ , these , vector , vty + , filepath default-language: Haskell2010 -test-suite potato-flow-test +test-suite tinytools-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: