WiQEE.hs 6.88 KB
Newer Older
1
2
3
4
{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-}
module Main where

import Definitive
5
import Language.Format
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
import Algebra.Monad.Concatenative
import System.IO (openFile,hIsTerminalDevice,IOMode(..),hClose)
import System.Environment (getArgs,lookupEnv)
import System.IO.Unsafe (unsafeInterleaveIO)
import Data.IORef
import Data.CaPriCon
import CaPriCon.Run
import System.FilePath (dropFileName,(</>))
import qualified Haste.Foreign as JS
import qualified Haste as JS
import qualified Haste.DOM as JS
import qualified Haste.Events as JS
import qualified Haste.Concurrent as JS
import qualified Haste.Ajax as JS
import qualified Haste.JSString as JSS
import qualified Haste.LocalStorage as JS
22
import qualified Haste.Binary as JS
23
import qualified Prelude as P
24
import qualified Data.Array.Unboxed as Arr
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47

instance Semigroup JS.JSString where (+) = JSS.append
instance Monoid JS.JSString where zero = JSS.empty
instance Sequence JS.JSString where splitAt = JSS.splitAt
instance StackSymbol JS.JSString where
  atomClass c = case c JSS.! 0 of
    '{' | JSS.length c==1 -> OpenBrace
    '}' | JSS.length c==1 -> CloseBrace
    '\'' -> Quoted (drop 1 c)
    '"' -> Quoted (take (JSS.length c-2) (drop 1 c))
    ':' -> Comment (drop 1 c)
    _ -> maybe (Other c) Number $ matches Just readable (toString c)
instance IsCapriconString JS.JSString where
  toString = JSS.unpack

instance Functor JS.CIO where map = P.fmap
instance SemiApplicative JS.CIO where (<*>) = (P.<*>)
instance Unit JS.CIO where pure = P.return
instance Applicative JS.CIO
instance Monad JS.CIO where join = (P.>>=id)
instance MonadIO JS.CIO where liftIO = JS.liftIO
instance MonadSubIO JS.CIO JS.CIO where liftSubIO = id

48
49
50
51
52
53
54
instance Serializable Word8 ([Word8] -> [Word8]) [Word8] Char where encode _ c = (fromIntegral (fromEnum c):)
instance Format Word8 ([Word8] -> [Word8]) [Word8] Char where datum = datum <&> \x -> toEnum (fromEnum (x::Word8))
instance Format Word8 ([Word8] -> [Word8]) [Word8] (ReadImpl  JS.CIO String String) where datum = return (ReadImpl getString)
instance Format Word8 ([Word8] -> [Word8]) [Word8] (ReadImpl  JS.CIO String [Word8]) where datum = return (ReadImpl getBytes)
instance Format Word8 ([Word8] -> [Word8]) [Word8] (WriteImpl JS.CIO String String) where datum = return (WriteImpl setString)
instance Format Word8 ([Word8] -> [Word8]) [Word8] (WriteImpl JS.CIO String [Word8]) where datum = return (WriteImpl setBytes)

55
runComment c = unit
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
toWordList :: JS.JSString -> [Word8]
toWordList = map (fromIntegral . fromEnum) . toString 

getString :: String -> JS.CIO (Maybe String)
getString file = do
  mres <- liftIO $ JS.getItem (fromString file)
  case mres of
    Right res -> return (Just $ toString (res :: JS.JSString))
    Left _ -> do
      here <- toString <$> JS.getLocationHref
        
      let url = fromString (dropFileName here</>file)
      res <- JS.ajax JS.GET url
      case res of
        Left JS.NetworkError -> fill Nothing $ JS.alert $ "Network error while retrieving "+url
        Left (JS.HttpError n msg) -> fill Nothing $ JS.alert $ "HTTP error "+fromString (show n)+": "+msg
        Right val -> map Just $ liftIO $ JS.setItem (fromString file) val >> return (toString (val :: JS.JSString))
getBytes :: String -> JS.CIO (Maybe [Word8])
getBytes file = do
  mres <- liftIO $ JS.getItem (fromString file)
  case mres of
    Right res -> return (Just $ toWordList (res :: JS.JSString))
    Left _ -> do
      here <- toString <$> JS.getLocationHref
        
      let url = fromString (dropFileName here</>file)
      res <- JS.ajax JS.GET url
      case res of
        Left JS.NetworkError -> fill Nothing $ JS.alert $ "Network error while retrieving "+url
        Left (JS.HttpError n msg) -> fill Nothing $ JS.alert $ "HTTP error "+fromString (show n)+": "+msg
        Right val -> map Just $ liftIO $ JS.setItem (fromString file) val >> return (toWordList val)
setString :: String -> String -> JS.CIO ()
setString f v = liftIO $ JS.setItem (fromString f) (fromString v :: JS.JSString)
setBytes :: String -> [Word8] -> JS.CIO ()
setBytes f v = setString f (map (toEnum . fromIntegral) v)
91
92

hasteDict :: COCDict JS.CIO String
93
hasteDict = cocDict ("0.8.1.3-js" :: String) getString getBytes setString setBytes
94
95
96

main :: IO ()
main = JS.concurrent $ void $ do
97
98
  JS.wait 200

99
100
101
102
103
104
105
106
107
108
109
110
111
  let runWordsState ws st = ($st) $ from (stateT.concatT) $^ do
        foldr (\w tl -> do
                  x <- runExtraState (getl endState)
                  unless x $ do execSymbol runCOCBuiltin runComment w; tl) unit ws
        out <- runExtraState (outputText <~ \x -> (id,x))
        return (out "")
      withSubElem root cl = JS.withElemsQS root ('.':cl) . traverse_
      withSubElems _ [] k = k []
      withSubElems root (h:t) k = withSubElem root h $ \h' -> withSubElems root t $ \t' -> k (h':t')
  
  prelude <- JS.withElem "capricon-prelude" (\e -> JS.getProp e "textContent")
  (initState,_) <- runWordsState (map fromString $ stringWords prelude) (defaultState hasteDict (COCState False [] zero id))

112
  roots <- JS.elemsByQS JS.documentBody ".capricon-steps, code.capricon"
113
114
  Just console <- JS.elemById "capricon-console"

115
116
  (\k -> foldr k (\_ _ -> unit) roots initState "") $ \root next state pref -> do
    isCode <- JS.hasClass root "capricon"
117

118
119
120
    if isCode
      then do
      p <- JS.getProp root "textContent"
121
      next state (pref+p+" pop ")
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
      else do
        JS.wait 10
    
        root' <- cloneNode root
        JS.toggleClass root' "capricon-frame"
        rootChildren <- JS.getChildren root'
        rootTitle <- JS.newElem "h3" <*= \head -> JS.appendChild head =<< JS.newTextElem "CaPriCon Console"
        closeBtn <- JS.newElem "button" <*= \but -> JS.appendChild but =<< JS.newTextElem "Close"
        JS.appendChild rootTitle closeBtn
        JS.appendChild console root'
        JS.setChildren root' (rootTitle:rootChildren)
    
        withSubElems root ["capricon-trigger"] $ \[trig] -> void $ do
          withSubElems root' ["capricon-input"] $ \[inp] -> void $ do
            let toggleActive = do
                  JS.toggleClass root' "active"
                  JS.focus inp
            JS.onEvent closeBtn JS.Click (const toggleActive)
            JS.onEvent trig JS.Click $ \_ -> toggleActive
        withSubElems root' ["capricon-input","capricon-output"] $ \[inp,out] -> do
          JS.withElemsQS root' ".capricon-context" $ \case
            [con] -> do
              context <- JS.getProp con "textContent"
              let text = pref+" "+context
              (state',_) <- runWordsState (stringWords text) state
              JS.onEvent inp JS.KeyPress $ \case
                JS.KeyData 13 False False False False -> do
                  Just v <- JS.getValue inp
                  (_,x) <- runWordsState (stringWords v) state'
                  JS.setProp out "textContent" (toString x)
                _ -> unit
              next state' ""
154
155
156

cloneNode :: MonadIO m => JS.Elem -> m JS.Elem
cloneNode x = liftIO $ JS.ffi "(function (n) { return n.cloneNode(true); })" x