diff --git a/Data/Editable.hs b/Data/Editable.hs new file mode 100644 --- /dev/null +++ b/Data/Editable.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DefaultSignatures, FlexibleContexts, ScopedTypeVariables, TypeOperators, DeriveGeneric, FlexibleInstances, ScopedTypeVariables, OverloadedStrings, UndecidableInstances, OverlappingInstances #-} +module Data.Editable (editor, Editable, Parseable(..)) where + +import GHC.Generics +import Graphics.Vty.Widgets.All +import qualified Data.Text as T +import Graphics.Vty hiding (Button) +import Control.Concurrent +import Text.Read +import Data.Monoid +import Data.Typeable +import Data.IORef + +-- | A type is parseable if you can: +-- +-- * From a string return either a value or an error message. +-- +-- * Represent a value as a string. +-- +-- * Showing a value then reading it yields the same value. +-- +-- * The type can be pretty printed. +-- +-- With overlapping instances, you get this instance for free for any +-- type that is in 'Show', 'Read' and 'Typeable'. The 'String' instance is also +-- provided so quotes are not required. +class Parseable a where + reader :: String -> Either String a + shower :: a -> String + typeName :: a -> String + +instance Parseable [Char] where + reader = Right + shower = id + typeName _ = "String" + +instance (Show a, Read a, Typeable a) => Parseable a where + reader = readEither + shower = show + typeName = show . typeRep . proxy + where + proxy :: a -> Proxy a + proxy _ = Proxy + +-- | Launch an editor for a value with @editor@. +-- Editable can be derived with @instance Editable a@ so long as: +-- +-- * @a@ instances 'Generic' (i.e. have @deriving Generics@ on the type). +-- +-- * All the constructors' fields' types are 'Parseable'. +class Editable a where + -- | Launch an interactive editor for a value. + editor :: a -> IO a + + default editor :: (Generic a, GEditable (Rep a)) => a -> IO a + editor = fmap to . geditor Nothing Nothing . from + +class GEditable f where + geditor :: Maybe String -> Maybe String -> f a -> IO (f a) + +instance (Parseable e) => GEditable (K1 i e) where + geditor t c = fmap K1 . (\x -> edit t c Nothing x) . unK1 + +instance (GEditable e, Constructor c) => GEditable (M1 C c e) where + geditor t _ x = fmap M1 . geditor t (Just $ conName x) $ unM1 x + +instance (GEditable e, Datatype c) => GEditable (M1 D c e) where + geditor _ c x = fmap M1 . geditor (Just $ datatypeName x) c $ unM1 x + +instance (GEditable e, Selector c) => GEditable (M1 S c e) where + geditor t c = fmap M1 . geditor t c . unM1 + +instance (GEditable b, GEditable c) => GEditable (b :*: c) where + geditor t d (b :*: c) = do + l <- geditor t d b + r <- geditor t d c + return (l :*: r) + +instance (GEditable b, GEditable c) => GEditable (b :+: c) where + geditor t c (L1 l) = fmap L1 $ geditor t c l + geditor t c (R1 r) = fmap R1 $ geditor t c r + +instance GEditable U1 where + geditor _ _ U1 = do + putStrLn "Editing () yields ()" -- not so true, can't pick ⊥ + return U1 + +-- the vty editor + +edit :: Parseable a => Maybe String -> Maybe String -> Maybe String -> a -> IO a +edit datatype fieldName pError initialV = do + -- To stop VTY from catching GHCI's first enter keypress + threadDelay 1 + + isBottom <- newIORef False + + e <- editWidget + setEditText e (T.pack (shower initialV)) + setEditCursorPosition (0, length (shower initialV)) e + + fg <- newFocusGroup + _ <- addToFocusGroup fg e + + be <- bordered =<< boxFixed 40 1 e + + c <- centered =<< ((plainText $"Data type: " <> maybe "unknown" T.pack datatype) + <--> plainText ("Constructor: " <> maybe "unknown" T.pack fieldName) + <--> plainText ("Field type: " <> (T.pack (typeName initialV))) + <--> plainText (maybe "" (T.pack . (++) "Parse error: ") pError) + <--> (return be) + <--> plainText "Push ESC to use ⊥." + >>= withBoxSpacing 1 ) + + coll <- newCollection + _ <- addToCollection coll c fg + + fg `onKeyPressed` \_ k _ -> + case k of + KEsc -> shutdownUi >> writeIORef isBottom True >> return True + KEnter -> shutdownUi >> return True + _ -> return False + + runUi coll defaultContext + + isb <- readIORef isBottom + if isb then return undefined + else do + res <- T.unpack `fmap` getEditText e + case reader res of + Right x -> return x + Left er -> do + edit datatype fieldName (Just $ "Failed to parse: " ++ show res ++ "\n" ++ er) initialV diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2014, Maxwell Swadling +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/demo.hs b/demo.hs new file mode 100644 --- /dev/null +++ b/demo.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} +module Demo where + +import Data.Editable +import GHC.Generics + +data Foo = Bar String Int | Baz Int + deriving (Show, Generic) + +instance Editable Foo + +main = do + let before = Bar "Words" 4 + print before + after <- editor before + print after diff --git a/editable.cabal b/editable.cabal new file mode 100644 --- /dev/null +++ b/editable.cabal @@ -0,0 +1,39 @@ +name: editable +version: 1.0.0.0 +synopsis: Interactive editors for Generics +description: + Editable can derive editors for data types. + . + Add @deriving Generic@ and @instance Editable Foo@ to your + data type, and you can launch an editor for it with + @editor :: Editable a => a -> IO a@. + . + @ + {-# LANGUAGE DeriveGeneric #-} + module Demo where + . + import Data.Editable + import GHC.Generics + . + data Foo = Bar String Int | Baz Int + deriving (Show, Generic) + . + instance Editable Foo + @ + <> + +license: BSD2 +license-file: LICENSE +author: Maxwell Swadling +maintainer: maxwellswadling@gmail.com +copyright: Copyright (C) 2014 Maxwell Swadling +category: Data +build-type: Simple +extra-source-files: demo.hs +cabal-version: >=1.10 + +library + ghc-options: -Wall + exposed-modules: Data.Editable + build-depends: base >=4.6 && <4.8, text >=1.1 && <1.2, vty == 4.7.5, vty-ui == 1.7.* + default-language: Haskell2010