ref: b5a3c38d9a2bc8e61960d0eff46391c69f3ed112
parent: e4cba674fd187b7e0cfed853e588cff74e8c1703
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Sat Apr 13 14:40:02 EDT 2024
Move some Typeable stuff
--- a/lib/Data/IntMap.hs
+++ b/lib/Data/IntMap.hs
@@ -5,6 +5,7 @@
empty, lookup, insert, fromList, toList, insertWith, (!), keys
) where
import Prelude hiding(lookup)
+import {-# SOURCE #-} Data.Typeabledata IntMap a
= Empty
@@ -11,6 +12,7 @@
| Leaf Int a
| Node (IntMap a) (IntMap a) (IntMap a) (IntMap a)
--Xderiving (Show)
+ deriving (Typeable)
-- This works for y>0
divModX :: Int -> Int -> (Int, Int)
--- a/lib/Data/Map.hs
+++ b/lib/Data/Map.hs
@@ -9,6 +9,7 @@
insertBy, insertByWith, fromListByWith, fromListBy, lookupBy, empty, elems, size, toList, deleteBy,
) where
import Prelude hiding (lookup)
+import {-# SOURCE #-} Data.Typeabledata Map k a
= Nil -- empty tree
@@ -20,6 +21,7 @@
a -- element stored in the node
(Map k a) -- right subtree
--Xderiving(Show)
+ deriving (Typeable)
empty :: forall k a . Map k a
empty = Nil
--- a/lib/Data/Typeable.hs
+++ b/lib/Data/Typeable.hs
@@ -21,9 +21,7 @@
import Prelude
import Control.Monad.ST
import Data.Complex
-import Data.IntMap
import Data.IORef
-import Data.Map
import Data.Proxy
import Data.Ratio
import Data.STRef
@@ -162,7 +160,6 @@
instance Typeable Ptr where typeRep = prim "Ptr"
instance Typeable IOArray where typeRep = prim "IOArray"
instance Typeable IORef where typeRep = nullary "Data.IORef" "IORef"
-instance Typeable IntMap where typeRep = nullary "Data.IntMap" "IntMap"
instance Typeable [] where typeRep = nullary "Data.List_Type" "[]"
instance Typeable Complex where typeRep = nullary "Data.Complex" "Complex"
@@ -176,7 +173,6 @@
instance Typeable (,) where typeRep = nullary "Data.Tuple" ","
instance Typeable (->) where typeRep = prim "->"
instance Typeable Either where typeRep = nullary "Data.Either" "Either"
-instance Typeable Map where typeRep = nullary "Data.Map" "Map"
instance Typeable ST where typeRep = nullary "Control.Monad.ST" "ST"
instance Typeable STRef where typeRep = nullary "Data.STRef" "STRef"
--- /dev/null
+++ b/lib/System/Cmd.hs
@@ -1,0 +1,10 @@
+module System.Cmd(system) where
+import Foreign.C.String
+import System.Exit
+
+foreign import ccall "system" c_system :: CString -> IO Int
+
+system :: String -> IO ExitCode
+system s = do
+ r <- withCAString s c_system
+ return $ if r == 0 then ExitSuccess else ExitFailure r
--- /dev/null
+++ b/lib/simple-readline/System/Console/SimpleReadline.hs
@@ -1,0 +1,210 @@
+-- Copyright 2023 Lennart Augustsson
+-- See LICENSE file for full license.
+--
+-- Simple readline with line editing and history.
+-- Only assumes the terminal is capable of (sane) backspace.
+module System.Console.SimpleReadline(
+ getInputLine,
+ getInputLineHist,
+ getInputLineHistComp,
+ ) where
+import Prelude
+import Control.Monad
+import Data.Char
+import System.IO
+
+foreign import ccall "GETRAW" c_getRaw :: IO Int
+
+
+-- Get an input line with editing.
+-- Return Nothing if the input is ^D, otherwise the typed string.
+getInputLine :: String -> IO (Maybe String)
+getInputLine prompt = do
+ (_, r) <- loop (\ _ -> return []) ([],[]) "" ""
+ return r
+
+getInputLineHist :: FilePath -> String -> IO (Maybe String)
+getInputLineHist = getInputLineHistComp (\ _ -> return [])
+
+type CompleteFn = (String, String) -> IO [String]
+
+-- Get an input line with editing.
+-- Return Nothing if the input is ^D, otherwise the typed string.
+-- The FilePath gives the name of a file that stores the history.
+getInputLineHistComp :: CompleteFn -> FilePath -> String -> IO (Maybe String)
+getInputLineHistComp comp hfn prompt = do
+ mhdl <- openFileM hfn ReadMode
+ hist <-
+ case mhdl of
+ Nothing -> return []
+ Just hdl -> do
+ file <- hGetContents hdl
+ let h = lines file
+ seq (length h) (return h) -- force file to be read
+ putStr prompt
+ (hist', r) <- loop comp (reverse hist, []) "" ""
+-- putStrLn $ "done: " ++ hfn ++ "\n" ++ unlines hist'
+ writeFile hfn $ unlines hist'
+ return r -- XXX no type error
+
+getRaw :: IO Char
+getRaw = do
+ i <- c_getRaw
+ when (i < 0) $
+ error "getRaw failed"
+ return (chr i)
+
+type Hist = ([String], [String])
+
+loop :: CompleteFn -> Hist -> String -> String -> IO ([String], Maybe String)
+loop comp hist before after = do
+ hFlush stdout
+ i <- getRaw
+ loop' comp hist before after i
+
+loop' :: CompleteFn -> Hist -> String -> String -> Char -> IO ([String], Maybe String)
+loop' comp hist before after cmd = do
+ let
+ cur = reverse before ++ after
+ back n = putStr (replicate n '\b')
+ bsSpBs n = concat $ replicate n "\b \b"
+
+ ins c = do
+ putChar c
+ putStr after
+ back (length after)
+ add c = do
+ ins c
+ loop comp hist (c:before) after
+ backward =
+ case before of
+ [] -> noop
+ c:cs -> do
+ back 1
+ loop comp hist cs (c:after)
+ forward =
+ case after of
+ [] -> noop
+ c:cs -> do
+ putChar c
+ loop comp hist (c:before) cs
+ bol = do
+ back (length before)
+ loop comp hist [] cur
+ eol = do
+ putStr after
+ loop comp hist (reverse after ++ before) []
+ bs = do
+ case before of
+ [] -> noop
+ _:cs -> do
+ back 1
+ putStr after
+ putChar ' '
+ back (length after + 1)
+ loop comp hist cs after
+ del = do
+ case after of
+ [] -> noop
+ _:cs -> do
+ putStr cs
+ putChar ' '
+ back (length cs + 1)
+ loop comp hist before cs
+ send =
+ ret (Just cur)
+ ret ms = do
+ putChar '\n'
+ hFlush stdout
+ let
+ o = reverse (fst hist) ++ snd hist
+ l =
+ case ms of
+ Nothing -> []
+ Just [] -> []
+ Just s | not (null o) && s == last o -> []
+ | otherwise -> [s]
+ h = o ++ l
+ return (h, ms)
+ erase = do
+ eraseLine
+ loop comp hist [] []
+ noop = loop comp hist before after
+ kill = do
+ putStr after
+ putStr $ bsSpBs $ length after
+ loop comp hist before []
+
+ next =
+ case hist of
+ (_, []) -> noop
+ (p, l:n) -> setLine (l:p, n) l
+ previous =
+ case hist of
+ ([], _) -> noop
+ (l:p, n) -> setLine (p, l:n) l
+ setLine h s = do
+ eraseLine
+ putStr s
+ loop comp h (reverse s) ""
+
+ eraseLine = do
+ putStr after
+ putStr $ bsSpBs $ length before + length after
+
+ complete = do
+ alts <- comp (before, after)
+ case alts of
+ [] -> loop comp hist before after
+ [s] -> do mapM_ ins s; loop comp hist (reverse s ++ before) after
+ ss -> tabLoop ss
+
+ tabLoop (s:ss) = do
+ mapM_ ins s -- show first alternative
+ hFlush stdout
+ c <- getRaw
+ if c /= '\t' then
+ loop' comp hist (reverse s ++ before) after c
+ else do
+ let n = length s
+ back n -- back up this alternative
+ putStr after -- put back old text
+ putStr $ replicate n ' ' -- erase extra
+ back (n + length after) -- put cursor back
+ tabLoop (ss ++ [s]) -- try next alternative
+
+ exec i =
+ case i of
+ '\^D' -> -- CTL-D, EOF
+ if null before && null after then
+ ret Nothing
+ else
+ del
+ '\^B' -> backward -- CTL-B, backwards
+ '\^F' -> forward -- CTL-F, forwards
+ '\^A' -> bol -- CTL-A, beginning of line
+ '\^E' -> eol -- CTL-E, end of line
+ '\b' -> bs -- BS, backspace
+ '\DEL' -> bs -- DEL, backspace
+ '\r' -> send -- CR, return
+ '\n' -> send -- LF, return
+ '\^N' -> next -- CTL-N, next line
+ '\^P' -> previous -- CTL-P, previous line
+ '\^U' -> erase -- CTL-U, erase line
+ '\^K' -> kill -- CTL-K, kill to eol
+ '\t' -> complete -- TAB, complete word
+ '\ESC' -> do -- ESC
+ b <- getRaw
+ if b /= '[' then
+ noop
+ else do
+ c <- getRaw
+ case c of
+ 'A' -> previous
+ 'B' -> next
+ 'C' -> forward
+ 'D' -> backward
+ _ -> noop
+ _ -> if i >= ' ' && i < '\DEL' then add i else noop
+
+ exec cmd
--
⑨