Types.hs (7220B)
1 -- Copyright 2023 The Plunder Authors 2 -- Use of this source code is governed by a BSD-style license that can be 3 -- found in the LICENSE file. 4 5 {-# OPTIONS_GHC -Wall #-} 6 {-# OPTIONS_GHC -Werror #-} 7 {-# LANGUAGE NoFieldSelectors #-} 8 9 {-| 10 Types for Sire syntax trees (`Cmd`, `Exp`, etc). "Sire.Syntax" 11 parses `Rex` into concrete syntax trees, and "Sire.ReplExe" 12 does... everything else (TODO: modularize) 13 -} 14 module Sire.Types 15 ( SireState(..) 16 , Bind(..) 17 , BindData(..) 18 , mkNewBind 19 , ToBind(..) 20 , Lam(..) 21 , Sire(..) 22 , rexText, pexText 23 , planRex 24 , planText 25 , sireRex 26 , lamRex 27 , trk 28 , trkM 29 , trkRexM 30 , apple 31 , apple_ 32 , traceSire 33 , traceSire' 34 , traceSireId 35 , _traceSireId 36 ) 37 where 38 39 import PlunderPrelude 40 41 import Sire.Backend 42 import Data.Sorted (Tab) 43 import Fan (Fan(..), mkPin) 44 import Fan.Convert (ToNoun(toNoun)) 45 import Fan.PlanRex (PlanRex) 46 import Fan.JetImpl (doTrk, doTrkRex) 47 import Loot.Backend (loadShallow) 48 import Loot.ReplExe (showValue, pexRender) 49 import Loot.Syntax (joinRex) 50 import Rex (GRex(..), RexColorScheme(NoColors), RuneShape(..), 51 TextShape(..), rexFile) 52 53 54 -- Aliases --------------------------------------------------------------------- 55 56 type Pex = PlanRex 57 type Rex = GRex Any 58 59 60 -- Types ----------------------------------------------------------------------- 61 62 -- key=0 means "generate a key for me" 63 data ToBind = TO_BIND 64 { key :: Nat 65 , props :: Maybe Sire 66 , name :: Str 67 , value :: Sire 68 } 69 70 71 -- Formal Sire State ----------------------------------------------------------- 72 73 type Str = Nat 74 type Any = Fan 75 76 type Scope = Tab Any Bind 77 78 data SireState = SIRE_STATE 79 { nextKey :: Nat -- Next unique key. 80 , context :: Str -- The name of the current module 81 , scope :: Scope -- Current global namespace. 82 , modules :: Tab Any Scope -- Loaded modules. 83 } 84 85 {- 86 When bindings are decoded from PLAN, we *remember* the original 87 PLAN value. This way, if we convert back to a noun, we can just 88 use the old value. This avoids the needs to reconstruct the noun, 89 and preserves sharing (only one version of the binding need exist 90 in memory). 91 92 This is especially important, because binding noun are *huge*. 93 A binding inclides source code, and that source code inclues other 94 bindings, etc. 95 96 Sire-in-sire wont need to deal with this, since there is no separation 97 between the binding and the underlying noun. 98 -} 99 mkNewBind :: BindData -> Bind 100 mkNewBind d = 101 BIND d $ mkPin $ toNoun 102 (NAT d.key, d.value, sireNoun d.code, d.location, d.name, d.props) 103 104 105 -- Sire Types ------------------------------------------------------------------ 106 107 sireNoun :: Sire -> Any 108 sireNoun = go 109 where 110 goLam :: Lam -> Any 111 goLam l = toNoun (l.pin, l.mark, l.recr, l.tag, l.args, go l.body) 112 113 goBinds :: [Sire] -> Any 114 goBinds = ROW . fromList . map go 115 116 go :: Sire -> Any 117 go = \case 118 V n -> ROW $ arrayFromListN 2 ["V", NAT n] 119 K n -> ROW $ arrayFromListN 2 ["K", n] 120 G b -> ROW $ arrayFromListN 2 ["G", b.noun] 121 A f x -> ROW $ arrayFromListN 3 ["A", go f, go x] 122 L v b -> ROW $ arrayFromListN 3 ["L", go v, go b] 123 R v b -> ROW $ arrayFromListN 3 ["R", goBinds v, go b] 124 M x -> ROW $ arrayFromListN 2 ["M", go x] 125 F l -> ROW $ arrayFromListN 2 ["F", goLam l] 126 127 lamRex :: Lam -> Rex 128 lamRex l = 129 N OPEN rune [hed] (Just $ openApp $ sireRex l.body) 130 where 131 hed = N NEST "|" hedSons Nothing 132 133 hedSons = 134 [ inlineMark (word $ showName $ NAT l.tag) 135 , N PREF ".." [word (tshow l.args)] Nothing 136 ] 137 138 rune = if l.pin then "??" else "?" 139 140 inlineMark rex | l.mark = N PREF "**" [rex] Nothing 141 inlineMark rex | otherwise = rex 142 143 word :: Text -> GRex a 144 word n = T WORD n Nothing 145 146 showName :: Any -> Text 147 showName = \case 148 NAT n -> 149 case natUtf8 n of 150 Left{} -> tshow n 151 Right nm -> nm -- TODO What if it is valid text but not 152 -- valid WORD? Handle that too. 153 wut -> 154 error $ 155 (<>) "bad state: binding.name is not a NAT" 156 (unpack $ rexText $ C wut) 157 158 159 sireRex :: Sire -> Rex 160 sireRex = \case 161 V v -> N PREF "$" [word (tshow v)] Nothing 162 K v -> C v 163 G b -> gloRex b 164 A f x -> appRex f [x] 165 L v x -> N OPEN "@" [sireRex v] $ Just $ openApp $ sireRex x 166 R v x -> case v of 167 [] -> sireRex x 168 a:as -> N OPEN "@@" [binds a as] $ Just $ openApp $ sireRex x 169 M sir -> N PREF "**" [sireRex sir] Nothing 170 F lam -> lamRex lam 171 where 172 binds v [] = N OPEN "=" [sireRex v] $ Nothing 173 binds v (x:xs) = N OPEN "=" [sireRex v] $ Just (binds x xs) 174 175 gloRex b = 176 T WORD (showName b.bd.name) 177 $ Just 178 $ N NEST "," [word (tshow b.bd.key)] 179 $ Nothing 180 181 appRex (A f x) xs = appRex f (x:xs) 182 appRex f xs = niceApp (sireRex <$> (f:xs)) 183 184 niceApp xs = case (all isSimpleClosed xs, reverse xs) of 185 ( _, [] ) -> error "niceApp: impossible" 186 ( True, _ ) -> N NEST "|" xs Nothing 187 ( False, l:ls ) -> N OPEN "|" (reverse ls) (Just $ openApp l) 188 189 planRex :: Any -> GRex Void 190 planRex = showValue . loadShallow 191 192 planText :: Any -> Text 193 planText = 194 let ?rexColors = NoColors 195 in rexFile . planRex 196 197 rexText :: Rex -> Text 198 rexText = 199 let ?rexColors = NoColors 200 in rexFile . joinRex . fmap handleEmbed 201 where 202 handleEmbed :: Any -> GRex Void 203 handleEmbed x = N style "↓" [rex] Nothing 204 where rex = planRex x 205 style = if isClosed rex then PREF else OPEN 206 207 pexText :: Pex -> Text 208 pexText = rexText . pexRender (fmap absurd . planRex) 209 210 isClosed :: GRex a -> Bool 211 isClosed (N OPEN _ _ _) = False 212 isClosed (T LINE _ _) = False 213 isClosed _ = True 214 215 isSimpleClosed :: GRex a -> Bool 216 isSimpleClosed (N OPEN _ _ _) = False 217 isSimpleClosed (N NEST "|" _ _) = False 218 isSimpleClosed _ = True 219 220 openApp :: GRex a -> GRex a 221 openApp (N NEST "|" ss h) = N OPEN "|" ss h 222 openApp rex = rex 223 224 225 -------------------------------------------------------------------------------- 226 227 trkM :: Monad m => Any -> m () 228 trkM msg = do 229 let !() = doTrk msg () 230 pure () 231 232 trkRexM :: Monad m => Rex -> m () 233 trkRexM rex = do 234 let !() = doTrkRex rex () 235 pure () 236 237 trk :: Any -> a -> a 238 trk = doTrk 239 240 -------------------------------------------------------------------------------- 241 242 apple :: Sire -> [Sire] -> Sire 243 apple = foldl' A 244 245 apple_ :: [Sire] -> Sire 246 apple_ [] = error "apple_ given nothing to work with" 247 apple_ (f:xs) = apple f xs 248 249 traceSire' :: Text -> Sire -> a -> a 250 traceSire' context sire result = 251 doTrkRex it result 252 where 253 it = N OPEN "#" [T WORD context Nothing] 254 $ Just 255 $ sireRex sire 256 257 traceSire :: Text -> Sire -> a -> a 258 traceSire _context _sire result = result 259 -- traceSire = traceSire' 260 261 traceSireId :: Text -> Sire -> Sire 262 traceSireId context sire = traceSire' context sire sire 263 264 _traceSireId :: Text -> Sire -> Sire 265 _traceSireId _context sire = sire