Skip to content

Commit 3c05b29

Browse files
hhefestohhefesto
committed
Integrate telomare-evaluare to telomare repo
1 parent ae73716 commit 3c05b29

3 files changed

Lines changed: 270 additions & 1 deletion

File tree

‎app/Evaluare.hs‎

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

‎flake.nix‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,7 @@
1515
imports = [ inputs.haskell-flake.flakeModule ];
1616
perSystem = { self', system, pkgs, ... }: {
1717
haskellProjects.default = {
18-
basePackages = pkgs.haskell.packages.ghc98;
18+
basePackages = pkgs.haskell.packages.ghc96;
1919
# To get access to non-Haskell dependencies one most add them to `extraBuildDepends`
2020
# and then use the haskell package `which` to locate the Filepath of the executable
2121
# that's being added. In this toy example we'll be using the non-Haskell dependency

‎telomare.cabal‎

Lines changed: 49 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -104,6 +104,55 @@ executable telomare-repl
104104
, free
105105
default-language: Haskell2010
106106

107+
executable telomare-evaluare
108+
hs-source-dirs: app
109+
main-is: Evaluare.hs
110+
ghc-options: -threaded -Wall
111+
build-depends:
112+
base,
113+
containers,
114+
reflex,
115+
reflex-vty,
116+
text,
117+
time,
118+
transformers,
119+
vty,
120+
telomare,
121+
mtl,
122+
free,
123+
strict
124+
default-language: Haskell2010
125+
-- other-modules: Example.CPU
126+
default-extensions:
127+
BangPatterns
128+
ConstraintKinds
129+
CPP
130+
DataKinds
131+
DefaultSignatures
132+
DeriveFunctor
133+
DeriveGeneric
134+
FlexibleContexts
135+
FlexibleInstances
136+
FunctionalDependencies
137+
GADTs
138+
GeneralizedNewtypeDeriving
139+
KindSignatures
140+
LambdaCase
141+
MultiParamTypeClasses
142+
MultiWayIf
143+
OverloadedStrings
144+
PatternGuards
145+
PolyKinds
146+
QuasiQuotes
147+
RankNTypes
148+
RecursiveDo
149+
ScopedTypeVariables
150+
StandaloneDeriving
151+
TemplateHaskell
152+
TupleSections
153+
TypeApplications
154+
TypeFamilies
155+
107156
test-suite telomare-test
108157
type: exitcode-stdio-1.0
109158
hs-source-dirs: test

0 commit comments

Comments
 (0)