|
| 1 | +module Main where |
| 2 | + |
| 3 | +import Control.Comonad.Cofree (Cofree ((:<))) |
| 4 | +import qualified Control.Exception as Exception |
| 5 | +import Control.Monad |
| 6 | +import Control.Monad.Fix (MonadFix) |
| 7 | +import Data.Bifunctor (first) |
| 8 | +import Data.Either (fromLeft) |
| 9 | +import Data.Map (Map) |
| 10 | +import qualified Data.Map as Map |
| 11 | +import Data.Text (Text) |
| 12 | +import qualified Data.Text as T |
| 13 | +import qualified Data.Text.Zipper as TZ |
| 14 | +import qualified Graphics.Vty as V |
| 15 | +import PrettyPrint (PrettierIExpr (..)) |
| 16 | +import Reflex |
| 17 | +import Reflex.Vty |
| 18 | +import System.Environment (getArgs) |
| 19 | +import qualified System.IO.Strict as Strict |
| 20 | +import qualified Telomare as Tel |
| 21 | +import Telomare (IExpr (..), IExprF (..)) |
| 22 | +import qualified Telomare.Eval as TE |
| 23 | +import Telomare.Parser (AnnotatedUPT, parsePrelude) |
| 24 | +import Text.Read (readMaybe) |
| 25 | + |
| 26 | +type VtyExample t m = |
| 27 | + ( MonadFix m |
| 28 | + , MonadHold t m |
| 29 | + , Reflex t |
| 30 | + , HasInput t m |
| 31 | + , HasImageWriter t m |
| 32 | + , HasDisplayRegion t m |
| 33 | + , HasFocus t m |
| 34 | + , HasFocusReader t m |
| 35 | + , HasTheme t m |
| 36 | + ) |
| 37 | + |
| 38 | +type Manager t m = |
| 39 | + ( HasLayout t m |
| 40 | + , HasFocus t m |
| 41 | + ) |
| 42 | + |
| 43 | +data Node = Node |
| 44 | + { _node_label :: Text |
| 45 | + , _node_eval :: Text |
| 46 | + , _node_selected :: Bool |
| 47 | + } |
| 48 | + deriving (Show, Eq) |
| 49 | + |
| 50 | +data NodeOutput t = NodeOutput |
| 51 | + { _nodeOutput_node :: Dynamic t Node |
| 52 | + , _nodeOutput_expand :: Event t Bool |
| 53 | + } |
| 54 | + |
| 55 | +node :: forall t m. ( VtyExample t m |
| 56 | + , HasLayout t m |
| 57 | + , HasInput t m |
| 58 | + , HasImageWriter t m |
| 59 | + ) |
| 60 | + => Node |
| 61 | + -> m (NodeOutput t) |
| 62 | +node n0 = do |
| 63 | + row $ do |
| 64 | + tile ( fixed . pure . (+1) . T.length . _node_label $ n0) $ do |
| 65 | + grout flex . text . pure . _node_label $ n0 |
| 66 | + pure () |
| 67 | + value :: Dynamic t Bool <- tile (fixed 4) $ checkbox def $ _node_selected n0 |
| 68 | + pure $ NodeOutput |
| 69 | + { _nodeOutput_node = Node (_node_label n0) (_node_eval n0) <$> value |
| 70 | + , _nodeOutput_expand = updated value |
| 71 | + } |
| 72 | + |
| 73 | +nodes :: forall t m. |
| 74 | + ( MonadHold t m |
| 75 | + , Manager t m |
| 76 | + , VtyExample t m |
| 77 | + , Adjustable t m |
| 78 | + , PostBuild t m |
| 79 | + ) |
| 80 | + => [Node] |
| 81 | + -> m (Event t Text) |
| 82 | +nodes nodes0 = do |
| 83 | + let nodeMaps0 = Map.fromList $ zip [0..] nodes0 |
| 84 | + rec |
| 85 | + listOut :: Dynamic t (Map Int (NodeOutput t)) |
| 86 | + <- listHoldWithKey nodeMaps0 updates $ \_ v -> grout (fixed 1) $ node v |
| 87 | + let expandedEvalText :: Event t (Int, Text) |
| 88 | + expandedEvalText = switchDyn $ |
| 89 | + leftmost |
| 90 | + . Map.elems |
| 91 | + . Map.mapWithKey (\k -> fmap ((k,) . _node_eval) |
| 92 | + . updated |
| 93 | + . _nodeOutput_node) |
| 94 | + <$> listOut |
| 95 | + nodesMap :: Dynamic t (Map Int Node) |
| 96 | + nodesMap = joinDynThroughMap $ fmap _nodeOutput_node <$> listOut |
| 97 | + updates :: Event t (Map Int (Maybe Node)) |
| 98 | + updates = justOneChecked <@> (fst <$> expandedEvalText) |
| 99 | + justOneChecked :: Behavior t (Int -> Map Int (Maybe Node)) |
| 100 | + justOneChecked = current $ |
| 101 | + (\n i -> Map.mapWithKey (\k n' -> if k == i |
| 102 | + then Just n' {_node_selected = True} |
| 103 | + else Just n' {_node_selected = False}) |
| 104 | + n |
| 105 | + ) <$> nodesMap |
| 106 | + pure $ snd <$> expandedEvalText |
| 107 | + |
| 108 | +nodeList :: ( VtyExample t m |
| 109 | + , Manager t m |
| 110 | + , MonadHold t m |
| 111 | + , Adjustable t m |
| 112 | + , PostBuild t m |
| 113 | + , HasInput t m |
| 114 | + ) |
| 115 | + => Event t Text -> [Node] -> m (Event t Text) |
| 116 | +nodeList e nodes0 = col $ do |
| 117 | + grout (fixed 1) $ text "" |
| 118 | + et <- grout flex $ nodes nodes0 |
| 119 | + pure $ leftmost [e, et] |
| 120 | + |
| 121 | +nodify :: Cofree IExprF (Int, IExpr) -> [Node] |
| 122 | +nodify = removeExtraNumbers . fmap go . allNodes 0 where |
| 123 | + removeExtraNumbers :: [Node] -> [Node] |
| 124 | + removeExtraNumbers = \case |
| 125 | + [] -> [] |
| 126 | + (x:xs) -> case (readMaybe . T.unpack . _node_label $ x) :: Maybe Int of |
| 127 | + Nothing -> x : removeExtraNumbers xs |
| 128 | + Just i -> x : removeExtraNumbers (drop (2 * i) xs) |
| 129 | + go :: (Int, Cofree IExprF (Int, IExpr)) -> Node |
| 130 | + go (i, x@(anno :< _)) = |
| 131 | + Node ( T.pack |
| 132 | + . (join (replicate i " ") <>) |
| 133 | + . head |
| 134 | + . lines |
| 135 | + . show |
| 136 | + . PrettierIExpr |
| 137 | + . Tel.forget |
| 138 | + $ x |
| 139 | + ) |
| 140 | + ( T.pack |
| 141 | + . (join (replicate i " ") <>) |
| 142 | + . (show . PrettierIExpr) |
| 143 | + . snd |
| 144 | + $ anno |
| 145 | + ) |
| 146 | + False |
| 147 | + allNodes :: Int -- * Indentation |
| 148 | + -> Cofree IExprF (Int, IExpr) |
| 149 | + -> [(Int, Cofree IExprF (Int, IExpr))] |
| 150 | + allNodes i = \case |
| 151 | + x@(_ :< ZeroF) -> (i, x) : [] |
| 152 | + x@(_ :< EnvF) -> (i, x) : [] |
| 153 | + x@(_ :< TraceF) -> (i, x) : [] |
| 154 | + x@(_ :< (SetEnvF a)) -> (i, x) : allNodes (i + 1) a |
| 155 | + x@(_ :< (DeferF a)) -> (i, x) : allNodes (i + 1) a |
| 156 | + x@(_ :< (PLeftF a)) -> (i, x) : allNodes (i + 1) a |
| 157 | + x@(_ :< (PRightF a)) -> (i, x) : allNodes (i + 1) a |
| 158 | + x@(_ :< (PairF a b)) -> (i, x) : allNodes (i + 1) a <> allNodes (i + 1) b |
| 159 | + x@(_ :< (GateF a b)) -> (i, x) : allNodes (i + 1) a <> allNodes (i + 1) b |
| 160 | + |
| 161 | +loadFiles :: [String] -> IO [(String, AnnotatedUPT)] |
| 162 | +loadFiles filenames = do |
| 163 | + filesStrings <- mapM Strict.readFile filenames |
| 164 | + case parsePrelude . unlines $ filesStrings of |
| 165 | + Right p -> pure p |
| 166 | + Left pe -> error pe |
| 167 | + |
| 168 | +main :: IO () |
| 169 | +main = do |
| 170 | + prelude :: [(String, AnnotatedUPT)] <- getArgs >>= loadFiles |
| 171 | + let go :: Text -> IO () |
| 172 | + go textErr = |
| 173 | + mainWidget $ initManager_ $ do |
| 174 | + let cfg = def |
| 175 | + { _textInputConfig_initialValue = TZ.fromText . T.pack . unlines $ |
| 176 | + [ "-- Example:" |
| 177 | + , "(\\x -> 0) 8" |
| 178 | + ] |
| 179 | + } |
| 180 | + textBox = boxTitle (pure roundedBoxStyle) "Telomare" $ |
| 181 | + multilineTextInput cfg |
| 182 | + escOrCtrlcQuit :: (Monad m, HasInput t m, Reflex t) => m (Event t ()) |
| 183 | + escOrCtrlcQuit = do |
| 184 | + inp <- input |
| 185 | + pure $ fforMaybe inp $ \case |
| 186 | + V.EvKey (V.KChar 'c') [V.MCtrl] -> Just () |
| 187 | + V.EvKey V.KEsc [] -> Just () |
| 188 | + _ -> Nothing |
| 189 | + getout <- escOrCtrlcQuit |
| 190 | + tile flex . box (pure roundedBoxStyle) . row $ do |
| 191 | + rec |
| 192 | + eEitherIExpr :: Event t (Either String IExpr) <- grout flex $ col $ do |
| 193 | + telomareTextInput :: TextInput t <- grout flex textBox |
| 194 | + pure . updated $ TE.eval2IExpr prelude . T.unpack <$> _textInput_value telomareTextInput |
| 195 | + grout (fixed 2) . col . text $ "" |
| 196 | + let -- telomareNodes :: Event t (Either String [Node]) |
| 197 | + telomareNodes = fmap (nodify . TE.tagIExprWithEval) <$> eEitherIExpr |
| 198 | + fromRightWith :: (a -> b) -> Either a b -> b |
| 199 | + fromRightWith f = \case |
| 200 | + Left x -> f x |
| 201 | + Right x -> x |
| 202 | + (_, eEventEval :: Event t (Either String (Event t Text))) |
| 203 | + <- runWithReplace (grout flex . col . text $ |
| 204 | + if T.length textErr > 0 |
| 205 | + then constant ("\nOops, something went wrong:\n\n" <> textErr <> "\n") |
| 206 | + else "" |
| 207 | + <> |
| 208 | + "\nWrite some Telomare code and interact with the generated AST") |
| 209 | + (mapM (nodeList (fromLeft ("Select a node to evaluate" :: Text) . first T.pack <$> eEitherIExpr)) <$> telomareNodes) |
| 210 | + et :: Event t Text <- switchHold (T.pack . fromLeft "woooooot99" <$> eEitherIExpr) |
| 211 | + (fromRightWith (\str -> T.pack str <$ telomareNodes) <$> eEventEval) |
| 212 | + bt <- hold "\nSelect nodes from the center pane and that'll evaluate here" $ ("\n" <>) . T.dropWhile (== ' ') <$> et |
| 213 | + grout flex . col . text $ bt |
| 214 | + pure () |
| 215 | + pure $ void getout |
| 216 | + res :: Either Exception.SomeException () <- Exception.try $ go "" |
| 217 | + case res of |
| 218 | + Left err -> go . T.pack . show $ err |
| 219 | + Right _ -> pure () |
0 commit comments