M Makefile => Makefile +5 -0
@@ 28,3 28,8 @@ doc: build
install: STACK_FLAGS += --copy-bins
install: build
+
+FORCE:
+%/ChangeLog.md: FORCE
+ scripts/changelog $* > $@
+
M capricon/ChangeLog.md => capricon/ChangeLog.md +50 -3
@@ 1,5 1,52 @@
-# Revision history for misc
+Revision history for capricon
+===============
-## 0.1.0.0 -- YYYY-mm-dd
+### release-capricon-0.13.1.1 / package-capricon-0.13.1.1
-* First version. Released on an unsuspecting world.
+ - Start updating the CaPriCon interpreter to enable "automatic universes"
+ - Correct the 'substitute' and 'intro before' builtins
+
+### release-capricon-0.13.1 / package-capricon-0.13.1
+
+ - Implement a new kind of "quiet" mustache in CaPriCon, to allow precise formatting commands to be inserted into a document
+
+### release-capricon-0.13 / package-capricon-0.13
+
+ - Upend the CaPriCon rendering pipeline, to allow for multiple output backends (for now, HTML and LaTeX)
+
+### release-capricon-0.12.3 / package-capricon-0.12.3
+
+ - Correct the behavior `type_of` function, causing it to fail on ill-typed terms instead of falsely succeeding
+
+### release-capricon-0.12.2.1 / package-capricon-0.12.2.1
+
+ - Make CaPriCon preserve whitespace at the end of documents
+
+### release-capricon-0.12.2 / package-capricon-0.12.2
+
+ - Update the CaPriCon HTML scaffold to fit the new stylesheet
+
+### release-capricon-0.12.1 / package-capricon-0.12.1
+
+ - Introduce a new 'set-stack' builtin, to go with the new backquote features
+ - Annotate matching braces with text spans when generating CaPriCon paragraphs, to allow better syntax highlighting to take place
+ - Output quoted characters as-is when generating Markdown from CaPriCon, to preserve the correct newline count
+ - Make the order of evaluation left-to-right at all backquote depths in concatenative languages.
+
+### release-capricon-0.12 / package-capricon-0.12
+
+ - Add support for writing custom examples after CaPriCon code blocks, to make the resulting pages more easily explorable
+ - Make better backquotes for CaPriCon
+
+### release-capricon-0.11
+
+ - Change WiQEE.hs to be used as a Web Worker instead of running in the application thread
+ - Release CaPriCon 0.11, now with a working module system
+
+### package-capricon-0.11
+
+ - Start offering basic SVG generation of formulae with the %g format in CaPriCon
+ - Adjust CaPriCon output to allow syntax highlighting to take place in code blocks
+ - Notify the user of changes in the console's state when it becomes active (in WiQEE)
+ - Define a 'cons' builtin for CaPriCon (and other concatenative languages)
+ - Remove the 'module' builtin in favor of the more flexible 'redirect' / 'set-vocabulary' combination
M capricon/capricon.cabal => capricon/capricon.cabal +5 -5
@@ 1,7 1,7 @@
-- Initial misc.cabal generated by cabal init. For further documentation,
-- see http://haskell.org/cabal/users-guide/
name: capricon
-version: 0.10.1
+version: 0.13.1.2
-- synopsis:
-- description:
license: GPL-3
@@ 34,19 34,19 @@ executable capricon
default-extensions: RebindableSyntax, ViewPatterns, TupleSections, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, LambdaCase, TypeOperators, RankNTypes, GeneralizedNewtypeDeriving, TypeFamilies
-- other-modules:
-- other-extensions:
- build-depends: base >=4.8 && <4.10,capricon >=0.10 && <0.11,definitive-base >=2.6 && <2.7,definitive-parser >=3.1 && <3.2
+ build-depends: base >=4.8 && <4.10,capricon >=0.13 && <0.14,definitive-base >=2.6 && <2.7,definitive-parser >=3.1 && <3.2
ghc-options: -Wincomplete-patterns -Wname-shadowing -W -Werror
hs-source-dirs: exe
default-language: Haskell2010
-executable WiQEE.js
+executable capricon-engine.js
if !impl(haste)
buildable: False
- main-is: WiQEE.hs
+ main-is: CaPriCon_Engine.hs
default-extensions: RebindableSyntax, ViewPatterns, TupleSections, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, LambdaCase, TypeOperators, RankNTypes, GeneralizedNewtypeDeriving, TypeFamilies
-- other-modules:
-- other-extensions:
haste-options: --opt-all
- build-depends: array >=0.5 && <0.6,base >=4.8 && <4.10,capricon >=0.10 && <0.11,definitive-base >=2.6 && <2.7,definitive-parser >=3.1 && <3.2,filepath >=1.4 && <1.5,haste-lib
+ build-depends: array >=0.5 && <0.6,base >=4.8 && <4.10,capricon >=0.10 && <0.14,definitive-base >=2.6 && <2.7,definitive-parser >=3.1 && <3.2,filepath >=1.4 && <1.5,haste-lib
hs-source-dirs: exe
default-language: Haskell2010
M capricon/data/prelude => capricon/data/prelude +13 -35
@@ 12,47 12,25 @@
dup dict-keys import-keys
} def
-[ dict term-index term context io list arith string ] { import } each
-
-'Type { 0 universe } def
-
-'times { range { pop dup exec } each pop } def
-
-'foralls { { extro-forall } swap times } def
-'lambdas { { extro-lambda } swap times } def
-'applys { range { pop apply } each } def
-'applyl { { swap apply } each } def
+[ dict term-index construction query context io list arith string ] { import } each
'printf { format print pop } def
'show { "%v\n" printf } def
'show-stack { stack { show } each } def
-'show-context { "" hypotheses { dup variable type swap "%s : %v\n%s" format } each print pop } def
-
-'showdef { pattern-index 1 swapn swap index-insert set-pattern-index } def
-
-'external { dup open swap "%s.html" format module } def
-'stache { "%v" printf } def
-
-'vis { show-context "-------\n" printf show-stack } def
-
-'-> { dup 1 swapn swap intro { {@ dup @} variable } def } def
-'! 'extro-lambda $ def
-'? 'extro-forall $ def
-
-'use {
- dup open swap
- cache-dir "%s/%s.mdc" format module
- dup 'exports { import-keys } { pop } lookup
-} def
-'export { 'exports swap def } def
-
-'( '[ $ def
-') { ] applyl } def
-
-'defconstr { 1 dupn swap showdef def } def
+'times { range { pop dup exec } each pop } def
+'reverse { [ ] swap { cons } each } def
'mustache. { show } def
'tex { 'mustache. { "$%l$\n" printf 'mustache. {@ dup $ @} def } def } def
+'svg { 'mustache. { "<svg class='formula' width='150px' height='2em' viewBox='0 0 100 100' xmlns=\"http://www.w3.org/2000/svg\"><text class='formula-text' x='0' y='100'>%g</text></svg>" printf 'mustache. {@ dup $ @} def } def } def
'raw { 'mustache. { "%s\n" printf 'mustache. {@ dup $ @} def } def } def
-'recursor { dup 2 shaft -> variable mu ! } def
+'collect { { 'exports empty def {@ @} exec exports {@ vocabulary @} set-vocabulary } exec } def
+'exports empty def
+'export { exports swap dup $ insert 'exports swap def } def
+
+[ 'source-dir 'output-dir 'cache-dir ] { "" def } each
+
+'module { dup source-dir "%s%s" format source swap output-dir "%s%s.mdc" format redirect } def
+'require { dup dup " * Required module: [%s]\(%s.html\)\n" printf { {@ dup @} { module } collect } swap cache-dir "%s%s.mdo" format cache } def
+
M capricon/exe/CaPriCon.hs => capricon/exe/CaPriCon.hs +3 -3
@@ 21,8 21,8 @@ instance Format [Word8] (ReadImpl IO String [Word8]) where datum = return (ReadI
instance Format [Word8] (WriteImpl IO String String) where datum = return (WriteImpl writeString)
instance Format [Word8] (WriteImpl IO String [Word8]) where datum = return (WriteImpl (\x -> writeBytes x . pack))
-f_readString = (\x -> try (return Nothing) (Just<$>readString x))
-f_readBytes = (\x -> try (return Nothing) (Just . unpack<$>readBytes x))
+f_readString = (\x -> catch (return . Left . show) (Right<$>readString x))
+f_readBytes = (\x -> catch (return . Left . show) (Right . unpack<$>readBytes x))
nativeDict = cocDict VERSION_capricon f_readString f_readBytes writeString (\x -> writeBytes x . pack)
@@ 45,7 45,7 @@ main = do
str <- stringWords <$> if isTerm then getAll else readHString stdin
args <- (foldMap (\x -> [libdir</>x,x]) <$> getArgs) >>= map (stringWords . fold) . traverse (try (return []) . readString)
execS (foldr (\sym mr -> do
- execSymbol runCOCBuiltin outputComment sym
+ execSymbol runCOCBuiltin outputComment (atomClass sym)
(hasQuit,out) <- runExtraState (liftA2 (,) (getl endState) (getl outputText) <* (outputText =- id))
d <- runDictState get
lift (writeIORef symList (keys d))
A capricon/exe/CaPriCon_Engine.hs => capricon/exe/CaPriCon_Engine.hs +203 -0
@@ 0,0 1,203 @@
+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, DeriveGeneric, StandaloneDeriving #-}
+module Main where
+
+import Definitive
+import Language.Format
+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.Binary as JS hiding (get)
+import qualified Prelude as P
+import qualified Data.Array.Unboxed as Arr
+
+deriving instance Show BraceKind
+deriving instance Show s => Show (AtomClass s)
+
+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 -> Open Brace
+ ',' | JSS.length c==2 && c JSS.! 1 == '{' -> Open (Splice CloseConstant)
+ '$' | JSS.length c==2 && c JSS.! 1 == '{' -> Open (Splice CloseExec)
+ '}' | JSS.length c==1 -> Close
+ '\'' -> Quoted (drop 1 c)
+ '\8217' -> Quoted (drop 1 c)
+ '"' -> Quoted (take (JSS.length c-2) (drop 1 c))
+ ':' -> Comment (TextComment $ 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
+
+newtype FSIO a = FSIO (ReaderT JSFS JS.CIO a)
+ deriving (Functor,SemiApplicative,Unit,Applicative,MonadIO)
+instance P.Functor FSIO where fmap = map
+instance P.Applicative FSIO where (<*>) = (<*>)
+instance P.Monad FSIO where return = return ; (>>=) = (>>=)
+instance JS.MonadIO FSIO where liftIO = liftIO
+instance Monad FSIO where join = coerceJoin FSIO
+instance JS.MonadConc FSIO where
+ liftCIO x = FSIO (lift x)
+ fork (FSIO rx) = FSIO (rx & from readerT %~ \r x -> JS.fork (r x))
+instance MonadSubIO FSIO FSIO where liftSubIO = id
+
+instance Serializable [Word8] Char where encode _ c = ListBuilder (fromIntegral (fromEnum c):)
+instance Format [Word8] Char where datum = datum <&> \x -> toEnum (fromEnum (x::Word8))
+instance Format [Word8] (ReadImpl FSIO String String) where datum = return (ReadImpl getString)
+instance Format [Word8] (ReadImpl FSIO String [Word8]) where datum = return (ReadImpl getBytes)
+instance Format [Word8] (WriteImpl FSIO String String) where datum = return (WriteImpl setString)
+instance Format [Word8] (WriteImpl FSIO String [Word8]) where datum = return (WriteImpl setBytes)
+
+runComment c = unit
+toWordList :: JS.JSString -> [Word8]
+toWordList = map (fromIntegral . fromEnum) . toString
+
+type ErrorMessage = String
+
+collectConc :: (Monad m, JS.MonadConc m) => ((a -> IO ()) -> (err -> IO ()) -> IO ()) -> m (err :+: a)
+collectConc k = do
+ v <- JS.newEmptyMVar
+ JS.liftCIO $ JS.liftIO $ k (\x -> JS.concurrent $ JS.putMVar v (Right x)) (\err -> JS.concurrent $ JS.putMVar v (Left err))
+ JS.readMVar v
+
+fsSchema :: JS.JSAny -> IO ()
+fsSchema = JS.ffi "(CaPriCon.initFS)"
+
+newtype JSFS = JSFS JS.JSAny
+instance JS.ToAny JSFS where
+ toAny (JSFS fs) = fs
+ listToAny l = JS.listToAny (map (\(JSFS x) -> x) l)
+instance JS.FromAny JSFS where
+ fromAny x = return (JSFS x)
+ listFromAny x = map JSFS <$> JS.listFromAny x
+newFS_impl :: JS.JSString -> (JSFS -> IO ()) -> (JS.JSAny -> IO ()) -> IO ()
+newFS_impl = JS.ffi "(CaPriCon.newFS)" fsSchema
+
+newFS :: JS.JSString -> JS.CIO JSFS
+newFS db = do
+ ret <- collectConc (newFS_impl db)
+ case ret of
+ Left _ -> error $ "Couldn't open database backend for " + toString db
+ Right r -> return r
+
+getFSItem_impl :: JSFS -> JS.JSString -> (JS.JSString -> IO ()) -> (JS.JSAny -> IO ()) -> IO ()
+getFSItem_impl = JS.ffi "(CaPriCon.getFSItem)"
+
+getFSItem :: JS.JSString -> FSIO (JS.JSAny :+: JS.JSString)
+getFSItem file = FSIO ask >>= \fs -> collectConc (getFSItem_impl fs file)
+
+setFSItem_impl :: JSFS -> JS.JSString -> JS.JSString -> (JS.JSAny -> IO ()) -> (JS.JSAny -> IO ()) -> IO ()
+setFSItem_impl = JS.ffi "(CaPriCon.setFSItem)"
+
+setFSItem :: JS.JSString -> JS.JSString -> FSIO ()
+setFSItem file dat = void $ FSIO ask >>= \fs -> collectConc (setFSItem_impl fs file dat)
+
+getString :: String -> FSIO (ErrorMessage :+: String)
+getString fileS = do
+ let file = fromString fileS :: JS.JSString
+ mres <- getFSItem file
+ case mres of
+ Right res -> return (Right $ toString (res :: JS.JSString))
+ Left _ -> do
+ here <- JS.getLocationHref
+
+ let url = JSS.replace here (JSS.regex "/[^/]*$" "") ("/"+file)
+ res <- collectConc (JS.ffi "(CaPriCon.ajaxGetString)" url)
+ case res of
+ Left x -> liftIO (JS.fromAny x) <&> \(n,msg) -> Left . toString $ "HTTP error "+fromString (show (n::Int))+" while retrieving "+url+": "+msg
+ Right val -> Right (toString (val :: JS.JSString)) <$ setFSItem file val
+getBytes :: String -> FSIO (ErrorMessage :+: [Word8])
+getBytes fileS = do
+ let file = fromString fileS :: JS.JSString
+ mres <- getFSItem file
+ case mres of
+ Right res -> return (Right $ toWordList (res :: JS.JSString))
+ Left _ -> do
+ here <- JS.getLocationHref
+
+ let url = JSS.replace here (JSS.regex "/[^/]*$" "") ("/"+file)
+ res <- collectConc (JS.ffi "(CaPriCon.ajaxGetString)" url)
+ case res of
+ Left x -> liftIO (JS.fromAny x) <&> \(n,msg) -> Left . toString $ "HTTP error "+fromString (show (n::Int))+" while retrieving "+url+": "+msg
+ Right val -> Right (toWordList val) <$ setFSItem file val
+setString :: String -> String -> FSIO ()
+setString f v = setFSItem (fromString f) (fromString v :: JS.JSString)
+setBytes :: String -> [Word8] -> FSIO ()
+setBytes f v = setString f (map (toEnum . fromIntegral) v)
+
+
+type WiQEEState = StackState (COCState String) String (COCBuiltin FSIO String) (COCValue FSIO String)
+runWordsState :: [String] -> WiQEEState -> FSIO (WiQEEState,String)
+runWordsState ws st = ($st) $ from (stateT.concatT) $^ do
+ foldr (\w tl -> do
+ x <- runExtraState (getl endState)
+ let cl = atomClass w
+ liftIO (JS.ffi ("console.log" :: JS.JSString) (fromString ("Executing symbol: "+show w+" (class "+show cl+")") :: JS.JSString) :: IO ())
+ unless x $ do execSymbol runCOCBuiltin runComment cl; tl) unit ws
+ out <- runExtraState (outputText <~ \x -> (id,x))
+ return (out "")
+
+runWithFS :: JS.JSString -> FSIO a -> JS.CIO a
+runWithFS fsname (FSIO r) = newFS fsname >>= r^..readerT
+
+hasteDict = cocDict ("0.13.1.2-js" :: String) getString getBytes setString setBytes
+
+main :: IO ()
+main = do
+ -- JS.ffi "console.log" ("hasteMain called" :: JS.JSString) :: IO ()
+ Just msg <- JS.lookupAny capriconObject "event.data"
+ (req,reqID,stateID,code) <- JS.fromAny msg
+ sts <- JS.get capriconObject "states"
+ JS.concurrent $ runWithFS "CaPriCon" $ do
+ st <- case stateID of
+ 0 -> return (defaultState hasteDict (COCState False [] zero id))
+ _ -> liftIO $ map JS.fromOpaque $ JS.index sts (stateID-1)
+ case req :: Int of
+ -- run a block of code, and return a handle to a new state
+ 0 -> do
+ (st',_) <- runWordsState (stringWords (toString (code :: JS.JSString))) st
+ id <- appendState capriconObject st'
+ postMessage (reqID :: Int,id)
+
+ -- run a block of code, and return its output, discarding the new state
+ 1 -> do
+ (_,out) <- runWordsState (map toString $ stringWords (code :: JS.JSString)) st
+ postMessage (reqID :: Int,fromString out :: JS.JSString)
+
+ -- run a block of code, and return both its output, and the new state
+ 2 -> do
+ (st',out) <- runWordsState (map toString $ stringWords (code :: JS.JSString)) st
+ id <- appendState capriconObject st'
+ postMessage (reqID :: Int,fromString out :: JS.JSString,id)
+
+ _ -> error "Unhandled request type"
+
+appendState :: MonadIO m => JS.JSAny -> a -> m Int
+appendState obj x = liftIO $ JS.ffi "(function (o,a) { o.states.push(a); return o.states.length; })" obj (JS.toOpaque x)
+
+postMessage :: (MonadIO m,JS.ToAny a) => a -> m ()
+postMessage msg = liftIO $ JS.ffi "(function (m) { postMessage(m); })" (JS.toAny msg)
+
+capriconObject :: JS.JSAny
+capriconObject = JS.constant "CaPriCon"
D capricon/exe/WiQEE.hs => capricon/exe/WiQEE.hs +0 -157
@@ 1,157 0,0 @@
-{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-}
-module Main where
-
-import Definitive
-import Language.Format
-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
-import qualified Haste.Binary as JS
-import qualified Prelude as P
-import qualified Data.Array.Unboxed as Arr
-
-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
-
-instance Serializable [Word8] Char where encode _ c = ListBuilder (fromIntegral (fromEnum c):)
-instance Format [Word8] Char where datum = datum <&> \x -> toEnum (fromEnum (x::Word8))
-instance Format [Word8] (ReadImpl JS.CIO String String) where datum = return (ReadImpl getString)
-instance Format [Word8] (ReadImpl JS.CIO String [Word8]) where datum = return (ReadImpl getBytes)
-instance Format [Word8] (WriteImpl JS.CIO String String) where datum = return (WriteImpl setString)
-instance Format [Word8] (WriteImpl JS.CIO String [Word8]) where datum = return (WriteImpl setBytes)
-
-runComment c = unit
-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)
-
-hasteDict :: COCDict JS.CIO String
-hasteDict = cocDict ("0.10.1-js" :: String) getString getBytes setString setBytes
-
-main :: IO ()
-main = JS.concurrent $ void $ do
- maybe unit JS.focus =<< JS.elemById "content-scroll"
- JS.wait 200
-
- 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))
-
- roots <- JS.elemsByQS JS.documentBody ".capricon-steps, code.capricon"
- Just console <- JS.elemById "capricon-console"
-
- (\k -> foldr k (\_ _ -> unit) roots initState "") $ \root next state pref -> do
- isCode <- JS.hasClass root "capricon"
-
- if isCode
- then do
- p <- JS.getProp root "textContent"
- next state (pref+p+" pop ")
- 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' ""
-
-cloneNode :: MonadIO m => JS.Elem -> m JS.Elem
-cloneNode x = liftIO $ JS.ffi "(function (n) { return n.cloneNode(true); })" x
M capricon/src/Algebra/Monad/Concatenative.hs => capricon/src/Algebra/Monad/Concatenative.hs +85 -54
@@ 1,12 1,12 @@
{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, GeneralizedNewtypeDeriving, LambdaCase, DeriveGeneric #-}
module Algebra.Monad.Concatenative(
-- * Extensible stack types
- StackBuiltin(..),StackSymbol(..),StackVal(..),StackStep(..),StackClosure(..),execValue,
+ StackBuiltin(..),StackSymbol(..),StackVal(..),StackStep(..),StackComment(..),ClosureAction(..),StackClosure(..),execValue,
t'StackDict,
-- * The MonadStack class
StackState,defaultState,
MonadStack(..),
- AtomClass(..),
+ BraceKind(..),AtomClass(..),
-- ** A concrete implementation
ConcatT,concatT,Opaque(..)) where
@@ 17,61 17,82 @@ import GHC.Generics (Generic)
newtype Opaque a = Opaque a
deriving (Generic)
instance Show (Opaque a) where show _ = "#<opaque>"
-data StackStep s b a = VerbStep s | ConstStep (StackVal s b a) | CommentStep s | ClosureStep Bool (StackClosure s b a)
+
+data StackComment s = TextComment s
+ | BeginCodeParagraph Int s [s]
+ | EndCodeParagraph
+ | BeginCodeSpan s
+ | EndCodeSpan s
+ deriving (Show,Generic)
+data StackStep s b a = VerbStep s | ConstStep (StackVal s b a) | ExecStep (StackVal s b a) | CommentStep (StackComment s) | ClosureStep Bool (StackClosure s b a)
deriving (Show,Generic)
-data StackClosure s b a = StackClosure [(StackProgram s b a,StackClosure s b a)] (StackProgram s b a)
+data ClosureAction = CloseConstant | CloseExec
+ deriving (Show,Generic)
+data StackClosure s b a = StackClosure ClosureAction [(StackProgram s b a,StackClosure s b a)] (StackProgram s b a)
deriving (Show,Generic)
type StackProgram s b a = [StackStep s b a]
-i'StackClosure :: Iso' ([(StackProgram s b a,StackClosure s b a)],StackProgram s b a) (StackClosure s b a)
-i'StackClosure = iso (\(cs,c) -> StackClosure cs c) (\(StackClosure cs c) -> (cs,c))
+i'StackClosure :: Iso' ([(StackProgram s b a,StackClosure s b a)],StackProgram s b a,ClosureAction) (StackClosure s b a)
+i'StackClosure = iso (\(cs,c,act) -> StackClosure act cs c) (\(StackClosure act cs c) -> (cs,c,act))
t'ClosureStep :: Traversal' (StackStep s b a) (StackClosure s b a)
t'ClosureStep k (ClosureStep b c) = ClosureStep b<$>k c
t'ClosureStep _ x = pure x
-allSteps :: Fold' (StackClosure s b a) (StackStep s b a)
-allSteps = from i'StackClosure.(l'1.each.l'1.each .+ l'2.each)
-subClosure :: Int -> Fold' (StackClosure s b a) (StackClosure s b a)
+subClosure :: Int -> Traversal' (StackClosure s b a) (StackClosure s b a)
subClosure 0 = id
-subClosure n = (allSteps.t'ClosureStep.subClosure (n+1))
- .+ (from i'StackClosure.l'1.each.l'2.subClosure (n-1))
+subClosure n = \k (StackClosure act ps p) ->
+ StackClosure act
+ <$> traverse (\(ph,px) -> liftA2 (,)
+ (traversel (each.t'ClosureStep.subClosure (n+1)) k ph)
+ (traversel (subClosure (n-1)) k px)) ps
+ <*> traversel (each.t'ClosureStep.subClosure (n+1)) k p
+
+allSteps :: (forall f. Applicative f => StackClosure s b a -> f (StackClosure s b a))
+ -> Traversal' (StackClosure s b a) (StackStep s b a)
+allSteps sub k (StackClosure act ps p) =
+ StackClosure act<$>traverse (\(ph,c) -> liftA2 (,) (each k ph) (sub c)) ps<*>traverse k p
-closureSplices :: Fold' (StackClosure s b a) (StackClosure s b a)
-closureSplices = allSteps.t'ClosureStep.subClosure (1::Int)
+closureSplices :: Traversal' (StackClosure s b a) (StackClosure s b a)
+closureSplices = allSteps pure.t'ClosureStep.subClosure (1::Int)
runClosure execBuiltin' onComment clos = do
- p <- flatten =<< forl closureSplices clos (\c -> StackClosure [] <$> flatten c)
+ (_,p) <- flatten clos
stack =~ (StackProg p:)
- where flatten (StackClosure cs c) = do
- pref <- map fold $ for cs $ \(i,StackClosure _ p) -> (i+) <$> do
- traverse_ (runStep execBuiltin' onComment) p
- stack <~ \(h:t) -> (t,[ConstStep h])
- return (pref + c)
+ where flattenSteps = traversel (each.t'ClosureStep.subClosure 1)
+ (\c -> flatten c <&> \(act,p) -> StackClosure act [] p)
+ flatten (StackClosure act cs c) = (act,) <$> liftA2 (+)
+ (map fold $ for cs $ \(i,StackClosure act' _ p) -> (+) <$> flattenSteps i <*> do
+ traverse_ (runStep execBuiltin' onComment) p
+ stack <~ \case
+ (h:t) -> (t,[case act' of CloseConstant -> ConstStep h ; CloseExec -> ExecStep h])
+ [] -> ([],[]))
+ (flattenSteps c)
runStep execBuiltin' onComment (VerbStep s) = getl (dict.at s) >>= \case
- Just v -> runVal v
+ Just v -> runStep execBuiltin' onComment (ExecStep v)
Nothing -> stack =~ (StackSymbol s:)
- where runVal (StackBuiltin b) = execBuiltin' b
- runVal (StackProg p) = traverse_ (runStep execBuiltin' onComment) p
- runVal x = stack =~ (x:)
runStep _ _ (ConstStep v) = stack =~ (v:)
+runStep execBuiltin' onComment (ExecStep (StackProg p)) = traverse_ (runStep execBuiltin' onComment) p
+runStep execBuiltin' _ (ExecStep (StackBuiltin b)) = execBuiltin' b
+runStep _ _ (ExecStep x) = stack =~ (x:)
runStep _ onComment (CommentStep c) = onComment c
-runStep _ _ (ClosureStep True (StackClosure _ p)) = stack =~ (StackProg p:)
+runStep _ _ (ClosureStep True (StackClosure _ _ p)) = stack =~ (StackProg p:)
runStep execBuiltin' onComment (ClosureStep _ c) = runClosure execBuiltin' onComment c
data StackBuiltin b = Builtin_ListBegin | Builtin_ListEnd
- | Builtin_Clear | Builtin_Stack
+ | Builtin_Clear | Builtin_Stack | Builtin_SetStack
| Builtin_Pick | Builtin_Shift | Builtin_Shaft
| Builtin_Pop | Builtin_PopN
| Builtin_Dup | Builtin_DupN
| Builtin_Swap | Builtin_SwapN
- | Builtin_Range | Builtin_Each
+ | Builtin_Range | Builtin_Each | Builtin_Cons
| Builtin_Add | Builtin_Sub | Builtin_Mul | Builtin_Div | Builtin_Mod | Builtin_Sign
- | Builtin_DeRef | Builtin_Def
+ | Builtin_DeRef | Builtin_CurrentDict
+ | Builtin_Def | Builtin_SetCurrentDict
| Builtin_Exec
- | Builtin_CurrentDict | Builtin_Empty | Builtin_Insert | Builtin_Lookup | Builtin_Delete | Builtin_Keys
+ | Builtin_Empty | Builtin_Insert | Builtin_Lookup | Builtin_Delete | Builtin_Keys
| Builtin_Quote
| Builtin_Extra b
deriving (Show,Generic)
@@ 88,9 109,10 @@ t'StackDict :: Traversal' (StackVal s b a) (Map s (StackVal s b a))
t'StackDict k (StackDict d) = StackDict <$> k d
t'StackDict _ x = return x
+data BraceKind = Brace | Splice ClosureAction
data StackState st s b a = StackState {
_stack :: [StackVal s b a],
- _progStack :: [StackClosure s b a],
+ _progStack :: [(BraceKind,StackClosure s b a)],
_dict :: Map s (StackVal s b a),
_extraState :: st
}
@@ 98,63 120,69 @@ data StackState st s b a = StackState {
stack :: Lens' (StackState st s b a) [StackVal s b a]
stack = lens _stack (\x y -> x { _stack = y })
-progStack :: Lens' (StackState st s b a) [StackClosure s b a]
+progStack :: Lens' (StackState st s b a) [(BraceKind,StackClosure s b a)]
progStack = lens _progStack (\x y -> x { _progStack = y })
dict :: Lens' (StackState st s b a) (Map s (StackVal s b a))
dict = lens _dict (\x y -> x { _dict = y })
extraState :: Lens st st' (StackState st s b a) (StackState st' s b a)
extraState = lens _extraState (\x y -> x { _extraState = y })
-data AtomClass s = OpenBrace | CloseBrace | OpenSplice | CloseSplice | Number Int | Quoted s | Comment s | Other s
+data AtomClass s = Close | Open BraceKind | Number Int | Quoted s | Comment (StackComment s) | Other s
class Ord s => StackSymbol s where atomClass :: s -> AtomClass s
instance StackSymbol String where
- atomClass "{" = OpenBrace
- atomClass "{@" = OpenSplice
- atomClass "}" = CloseBrace
- atomClass "@}" = CloseSplice
+ atomClass "{" = Open Brace
+ atomClass ",{" = Open (Splice CloseConstant)
+ atomClass "${" = Open (Splice CloseExec)
+ atomClass "}" = Close
atomClass ('\'':t) = Quoted t
+ atomClass ('\8217':t) = Quoted t
atomClass ('"':t) = Quoted (init t)
- atomClass (':':t) = Comment t
+ atomClass (':':t) = Comment (TextComment t)
atomClass x = maybe (Other x) Number (matches Just readable x)
-execSymbolImpl :: (StackSymbol s, MonadState (StackState st s b a) m) => (StackBuiltin b -> m ()) -> (s -> m ()) -> s -> m ()
+execSymbolImpl :: (StackSymbol s, MonadState (StackState st s b a) m) => (StackBuiltin b -> m ()) -> (StackComment s -> m ()) -> AtomClass s -> m ()
execSymbolImpl execBuiltin' onComment atom = do
st <- get
- case (atomClass atom,st^.progStack) of
- (OpenBrace,_) -> progStack =~ (StackClosure [] []:)
-
- (OpenSplice,StackClosure cs p:ps) ->
- progStack =- StackClosure [] []:StackClosure ((reverse p,StackClosure [] []):cs) []:ps
- (CloseSplice,StackClosure cs p:StackClosure cs' p':ps) ->
- progStack =- StackClosure (set (t'1.l'2) (StackClosure (reverse cs) (reverse p)) cs') p':ps
+ case (atom,st^.progStack) of
+ (Open Brace,_) -> progStack =~ ((Brace,StackClosure CloseExec [] []):)
+ (Open s@(Splice act),(k,StackClosure act' cs p):ps) ->
+ progStack =- (s,StackClosure act [] []):(k,StackClosure act' ((reverse p,StackClosure act [] []):cs) []):ps
+ (Open (Splice _),[]) -> unit
+
+ (Close,(Splice _,StackClosure act cs p):(k,StackClosure act' cs' p'):ps) ->
+ progStack =- (k,StackClosure act' (set (t'1.l'2) (StackClosure act (reverse cs) (reverse p)) cs') p'):ps
- (CloseBrace,StackClosure cs p:ps) -> do
+ (Close,(Brace,StackClosure act cs p):ps) -> do
progStack =- ps
- let c = StackClosure (reverse cs) (reverse p)
+ let c = StackClosure act (reverse cs) (reverse p)
execStep ps (ClosureStep (not $ has (closureSplices .+ (from i'StackClosure.l'1.each.l'2)) c) c)
- (CloseBrace,[]) -> unit
- (OpenSplice,[]) -> unit
- (CloseSplice,_) -> unit
+ (Close,_) -> unit
(Quoted a,ps) -> execStep ps (ConstStep (StackSymbol a))
(Comment a,ps) -> execStep ps (CommentStep a)
(Number n,ps) -> execStep ps (ConstStep (StackInt n))
(Other s,ps) -> execStep ps (VerbStep s)
where execStep [] stp = runStep execBuiltin' onComment stp
- execStep (StackClosure cs p:ps) stp = progStack =- (StackClosure cs (stp:p):ps)
+ execStep ((k,StackClosure act cs p):ps) stp = progStack =- ((k,StackClosure act cs (stp:p)):ps)
-execBuiltinImpl :: (StackSymbol s, MonadState (StackState st s b a) m) => (b -> m ()) -> (s -> m ()) -> StackBuiltin b -> m ()
+execBuiltinImpl :: (StackSymbol s, MonadState (StackState st s b a) m) => (b -> m ()) -> (StackComment s -> m ()) -> StackBuiltin b -> m ()
execBuiltinImpl runExtra onComment = go
where
go Builtin_Def = get >>= \st -> case st^.stack of
(val:StackSymbol var:tl) -> do dict =~ insert var val ; stack =- tl
_ -> return ()
+ go Builtin_SetCurrentDict = get >>= \st -> case st^.stack of
+ (StackDict d:tl) -> do dict =- d ; stack =- tl
+ _ -> return ()
go Builtin_ListBegin = stack =~ (StackBuiltin Builtin_ListBegin:)
go Builtin_ListEnd = stack =~ \st -> let ex acc (StackBuiltin Builtin_ListBegin:t) = (acc,t)
ex acc (h:t) = ex (h:acc) t
ex acc [] = (acc,[])
in let (h,t) = ex [] st in StackList h:t
go Builtin_Stack = stack =~ \x -> StackList x:x
+ go Builtin_SetStack = stack =~ \case
+ (StackList s:_) -> s
+ st -> st
go Builtin_Clear = stack =- []
go Builtin_Pick = stack =~ \st -> case st of StackInt i:StackInt n:t | i<n, x:t' <- drop i t -> x:drop (n-i-1) t'
_ -> st
@@ 175,6 203,9 @@ execBuiltinImpl runExtra onComment = go
st -> st
go Builtin_Dup = stack =~ \st -> case st of x:t -> x:x:t ; _ -> st
go Builtin_DupN = stack =~ \st -> case st of StackInt n:t | x:_ <- drop n t -> x:t ; _ -> st
+ go Builtin_Cons = stack =~ \case
+ x:StackList l:st' -> StackList (x:l):st'
+ st -> st
go Builtin_Range = stack =~ \st -> case st of StackInt n:t -> StackList [StackInt i | i <- [0..n-1]]:t ; _ -> st
go Builtin_Each = do
st <- get
@@ 234,9 265,9 @@ execBuiltinImpl runExtra onComment = go
execVal _ = return ()
class (StackSymbol s,Monad m) => MonadStack st s b a m | m -> st s b a where
- execSymbol :: (b -> m ()) -> (s -> m ()) -> s -> m ()
- execProgram :: (b -> m ()) -> (s -> m ()) -> StackProgram s b a -> m ()
- execBuiltin :: (b -> m ()) -> (s -> m ()) -> StackBuiltin b -> m ()
+ execSymbol :: (b -> m ()) -> (StackComment s -> m ()) -> AtomClass s -> m ()
+ execProgram :: (b -> m ()) -> (StackComment s -> m ()) -> StackProgram s b a -> m ()
+ execBuiltin :: (b -> m ()) -> (StackComment s -> m ()) -> StackBuiltin b -> m ()
runStackState :: State [StackVal s b a] x -> m x
runExtraState :: State st x -> m x
runDictState :: State (Map s (StackVal s b a)) x -> m x
M capricon/src/CaPriCon/Run.hs => capricon/src/CaPriCon/Run.hs +161 -109
@@ 5,7 5,7 @@ import Definitive
import Language.Format
import Algebra.Monad.Concatenative
import Data.CaPriCon
-import Data.CaPriCon.Extraction (Algebraic(..),fromNode)
+import Data.CaPriCon.Extraction (Algebraic(..),fromTerm)
import GHC.Generics (Generic)
class Monad m => MonadSubIO io m where
@@ 15,18 15,13 @@ instance MonadSubIO io m => MonadSubIO io (ConcatT st b o s m) where
liftSubIO ma = lift $ liftSubIO ma
type COCAxiom str = str
-type MaxDelta = Int
-type UniverseConstraint = [Maybe MaxDelta]
-data UniverseConstraints = UniverseConstraints [UniverseConstraint]
-instance Semigroup UniverseConstraints where
- UniverseConstraints x + UniverseConstraints y = UniverseConstraints $ zipWith (zipWith (\_x _y -> zipWith max _x _y + _x + _y)) x y
-instance Monoid UniverseConstraints where zero = UniverseConstraints (repeat (repeat Nothing))
-data COCValue io str = COCExpr (ContextNode str (COCAxiom str))
+data COCValue io str = COCExpr (NormalTerm str (COCAxiom str))
| COCNull | COCError str
| COCConvertible (Maybe (Int,Int))
| COCAlgebraic (Algebraic str)
| COCDir (NodeDir str (COCAxiom str) ([str],StackVal str (COCBuiltin io str) (COCValue io str)))
deriving Generic
+instance ListSerializable ClosureAction ; instance ListFormat ClosureAction
instance (ListSerializable s,ListSerializable b,ListSerializable a) => ListSerializable (StackStep s b a)
instance (ListSerializable s,ListSerializable b,ListSerializable a) => ListSerializable (StackClosure s b a)
instance (ListSerializable s,ListSerializable b,ListSerializable a) => ListSerializable (StackVal s b a)
@@ 37,6 32,8 @@ instance (ListSerializable b) => ListSerializable (StackBuiltin b)
instance (ListFormat b) => ListFormat (StackBuiltin b)
instance (ListSerializable a) => ListSerializable (Opaque a)
instance (ListFormat a) => ListFormat (Opaque a)
+instance (ListSerializable s) => ListSerializable (StackComment s)
+instance (ListFormat s) => ListFormat (StackComment s)
instance ListSerializable str => ListSerializable (COCValue io str)
instance (IsCapriconString str,ListFormat str,IOListFormat io str) => ListFormat (COCValue io str)
@@ 46,11 43,11 @@ pattern StackCOC v = StackExtra (Opaque v)
takeLast n l = drop (length l-n) l
-showStackVal :: IsCapriconString str => (NodeDoc str -> str) -> NodeDir str (COCAxiom str) ([str],StringPattern str) -> [(str,Node str (COCAxiom str))] -> StackVal str (COCBuiltin io str) (COCValue io str) -> str
+showStackVal :: IsCapriconString str => (NodeDoc str -> str) -> NodeDir str (COCAxiom str) ([str],StringPattern str) -> [(str,Term str (COCAxiom str))] -> StackVal str (COCBuiltin io str) (COCValue io str) -> str
showStackVal toRaw dir ctx = fix $ \go _x -> case _x of
StackCOC _x -> case _x of
- COCExpr (ContextNode d e) -> -- "<"+show d+">:"+
- toRaw $ showNode' dir (map (second snd) $ takeLast d (freshContext ctx)) e
+ COCExpr (NormalTerm (NormalType _ c _) e) -> -- "<"+show d+">:"+
+ toRaw (showNode' dir (map (second snd) $ takeLast (length c) (freshContext ctx)) e)
COCNull -> "(null)"
COCError e -> "<!"+e+"!>"
COCDir d -> fromString $ show d
@@ 62,15 59,19 @@ showStackVal toRaw dir ctx = fix $ \go _x -> case _x of
StackDict d -> "[<"+intercalate "," (map (\(k,v) -> k+": "+go v) (d^.ascList))+">]"
StackProg p ->
let showStep (ConstStep x) = go x
+ showStep (ExecStep x) = "$("+go x+")"
showStep (ClosureStep b c) = fromString (show b)+":"+showClosure c
showStep (VerbStep v) = v
- showStep (CommentStep x) = ":"+x
+ showStep (CommentStep (TextComment x)) = ":"+x
+ showStep (CommentStep c) = ":<"+fromString (show c)+">"
showSteps p' = intercalate " " (map showStep p')
- showClosure (StackClosure cs c) = "{ "+intercalate " " (map (\(i,c') -> showSteps i+" "+showClosure c') cs + map showStep c)+" }"
+ showClosure (StackClosure act cs c) =
+ (case act of CloseExec -> "$" ; _ -> ",")
+ +"{ "+intercalate " " (map (\(i,c') -> showSteps i+" "+showClosure c') cs + map showStep c)+" }"
in "{ "+showSteps p+" }"
_ -> fromString $ show _x
data COCBuiltin io str = COCB_Print | COCB_Quit
- | COCB_Open (ReadImpl io str str) | COCB_ExecModule (WriteImpl io str str)
+ | COCB_Open (ReadImpl io str str) | COCB_Redirect (WriteImpl io str str)
| COCB_Cache (ReadImpl io str [Word8]) (WriteImpl io str [Word8])
| COCB_ToInt | COCB_Concat
@@ 87,10 88,10 @@ data COCBuiltin io str = COCB_Print | COCB_Quit
| COCB_ContextVars
| COCB_GetShowDir | COCB_SetShowDir | COCB_InsertNodeDir
- | COCB_Format
+ | COCB_Format | COCB_Render
deriving (Show,Generic)
-data ReadImpl io str bytes = ReadImpl (str -> io (Maybe bytes))
+data ReadImpl io str bytes = ReadImpl (str -> io (String :+: bytes))
data WriteImpl io str bytes = WriteImpl (str -> bytes -> io ())
instance Show (ReadImpl io str bytes) where show _ = "#<open>"
instance Show (WriteImpl io str bytes) where show _ = "#<write>"
@@ 109,48 110,69 @@ htmlQuote = fromString . foldMap qChar . toString
where qChar '<' = "<"
qChar '>' = ">"
qChar '&' = "&"
+ qChar '"' = """
qChar c = [c]
stringWords :: IsCapriconString str => str -> [str]
-stringWords = map fromString . fromBlank . toString
- where fromBlank (c:t) | c `elem` [' ', '\t', '\r', '\n'] = fromBlank t
- | c == '"' = fromQuote id t
- | otherwise = fromWChar (c:) t
- fromBlank "" = []
- fromQuote k ('"':t) = ('"':k "\""):fromBlank t
- fromQuote k ('\\':c:t) = fromQuote (k.(qChar c:)) t
+stringWords x = [w | (True,w) <- stringWordsAndSpaces True x]
+
+stringWordsAndSpaces :: IsCapriconString str => Bool -> str -> [(Bool,str)]
+stringWordsAndSpaces unquoteStrings = map (second fromString) . fromBlank id . toString
+ where fromBlank k (c:t) | c `elem` [' ', '\t', '\r', '\n'] = fromBlank (k.(c:)) t
+ | c == '"' = (False,k ""):fromQuote id t
+ | otherwise = (False,k ""):fromWChar (c:) t
+ fromBlank k "" = [(False,k "")]
+ fromQuote k ('"':t) = (True,'"':k "\""):fromBlank id t
+ fromQuote k ('\\':c:t) | unquoteStrings = fromQuote (k.(qChar c:)) t
where qChar 'n' = '\n' ; qChar 't' = '\t' ; qChar x = x
fromQuote k (c:t) = fromQuote (k.(c:)) t
- fromQuote k "" = ['"':k "\""]
- fromWChar k (c:t) | c `elem` [' ', '\t', '\r', '\n'] = k "":fromBlank t
+ fromQuote k "" = [(True,'"':k "\"")]
+ fromWChar k (c:t) | c `elem` [' ', '\t', '\r', '\n'] = (True,k ""):fromBlank (c:) t
| otherwise = fromWChar (k.(c:)) t
- fromWChar k "" = [k ""]
+ fromWChar k "" = [(True,k "")]
-literate :: forall str. IsCapriconString str => Parser String [str]
-literate = intercalate [":s\n"] <$> sepBy' (cmdline "> " <+? cmdline "$> " <+? commentline) (single '\n')
+literate :: forall str. IsCapriconString str => Parser String [StackComment str :+: str]
+literate = liftA2 (\pref r -> pref + [Left (TextComment $ fromString r)])
+ (intercalate [Left (TextComment "\n")] <$> sepBy' (cmdline "> " ">? " <+? cmdline "$> " "$>? " <+? commentline) (single '\n'))
+ remaining
where
- wrapResult :: Bool -> [str] -> [str]
- wrapResult isParagraph l = (if isParagraph then ":rbp" else ":rbs") : l + [if isParagraph then ":rep" else ":res"]
- cmdline :: Parser String () -> Parser String [str]
- cmdline pre = map (\x -> [":cp"+intercalate "\n" (map fst x)]
- + wrapResult True (foldMap snd x))
- (sepBy1' go (single '\n'))
- where go = do pre; many' (noneOf ['\n']) <&> \x -> (fromString x,map fromString (stringWords x+["steps."]))
- commentline = map (foldMap (pure . (":s"+) <|> \(x,t) -> t+[":cs"+x])) $ (<* lookingAt eol)
- $ many' (map (Left . fromString) (many1' (noneOf ['{','\n'] <+?
- (fill '{' $ single '{' <* lookingAt (noneOf ['{']))))
- <+? map Right (between "{{" "}}"
- (many1' (noneOf ['}'] <+? fill '}' (single '}' <* lookingAt (noneOf ['}'])))
- <&> \x -> (fromString x,wrapResult False (stringWords (fromString x)+["mustache."])))))
+ cmdline :: Parser String () -> Parser String () -> Parser String [StackComment str :+: str]
+ cmdline pre pre_ex = do
+ indent <- many' (oneOf [' ','\t'])
+ map (\(x,exs) -> [Left (TextComment $ fromString indent)
+ ,Left (BeginCodeParagraph (length x) (intercalate "\n" (map fst x)) exs)]
+ + map Right (foldMap snd x)
+ + [Left EndCodeParagraph])
+ ((,) <$> sepBy1' go (single '\n') <*> option' [] ("\n" >> sepBy1' go_ex (single '\n')))
+ where go = do pre; many' (noneOf ['\n']) <&> \x -> (fromString x,map fromString (stringWords x+["eol."]))
+ go_ex = do pre_ex; many' (noneOf ['\n']) <&> fromString
+ commentline :: Parser String [StackComment str :+: str]
+ commentline = map (foldMap ((pure . (Left . TextComment) <|>
+ \(x,t) -> Left (BeginCodeSpan x):map Right t+[Left (EndCodeSpan x)])
+ <|> map Right))
+ $ (<* lookingAt eol)
+ $ many' (map (Left . Left . fromString)
+ (many1' (noneOf ['{','\n']
+ <+? fill '{' (single '{' <* lookingAt (noneOf ['{','.']))))
+ <+?
+ map (Left . Right)
+ (between "{{" "}}"
+ (many1' (noneOf ['}'] <+? fill '}' (single '}' <* lookingAt (noneOf ['}'])))
+ <&> \x -> (fromString x,stringWords (fromString x)+["mustache."])))
+ <+?
+ map Right
+ (between "{." ".}"
+ (many1' (noneOf ['.'] <+? fill '.' (single '.' <* lookingAt (noneOf ['}']))))
+ <&> \x -> map fromString (stringWords x)))
data COCState str = COCState {
_endState :: Bool,
- _context :: [(str,Node str (COCAxiom str))],
+ _context :: Env str (NormalTerm str (COCAxiom str)),
_showDir :: NodeDir str (COCAxiom str) ([str],StringPattern str),
_outputText :: str -> str
}
endState :: Lens' (COCState str) Bool
endState = lens _endState (\x y -> x { _endState = y })
-context :: Lens' (COCState str) [(str,Node str (COCAxiom str))]
+context :: Lens' (COCState str) (Env str (NormalTerm str (COCAxiom str)))
context = lens _context (\x y -> x { _context = y })
showDir :: Lens' (COCState str) (NodeDir str (COCAxiom str) ([str],StringPattern str))
showDir = lens _showDir (\x y -> x { _showDir = y })
@@ 160,11 182,11 @@ outputText = lens _outputText (\x y -> x { _outputText = y })
pushError :: MonadStack (COCState str) str (COCBuiltin io str) (COCValue io str) m => str -> m ()
pushError s = runStackState $ modify $ (StackCOC (COCError s):)
-runInContext :: Env str ax -> MaybeT ((->) (Env str ax)) a -> Maybe a
+runInContext :: ax -> MaybeT ((->) ax) a -> Maybe a
runInContext c v = (v^..maybeT) c
modifyAllExprs :: MonadStack (COCState str) str (COCBuiltin io str) (COCValue io str) m
- => (ContextNode str (COCAxiom str) -> ContextNode str (COCAxiom str)) -> m ()
+ => (NormalTerm str (COCAxiom str) -> NormalTerm str (COCAxiom str)) -> m ()
modifyAllExprs f = do
let modStack (StackCOC (COCExpr e)) = StackCOC (COCExpr (f e))
modStack (StackDict d) = StackDict (map modStack d)
@@ 173,12 195,19 @@ modifyAllExprs f = do
runStackState $ modify $ map modStack
runDictState $ modify $ map modStack
modifyCOCEnv :: MonadStack (COCState str) str (COCBuiltin io str) (COCValue io str) m
- => Maybe (ContextNode str (COCAxiom str) -> ContextNode str (COCAxiom str),Env str (COCAxiom str)) -> m ()
+ => Maybe (NormalTerm str (COCAxiom str) -> NormalTerm str (COCAxiom str),Env str (NormalTerm str (COCAxiom str))) -> m ()
modifyCOCEnv Nothing = unit
modifyCOCEnv (Just (modE,ctx)) = do
runExtraState (context =- ctx)
modifyAllExprs modE
+execSymbolOrComment :: forall str io m.
+ (MonadSubIO io m,IsCapriconString str,
+ MonadStack (COCState str) str (COCBuiltin io str) (COCValue io str) m,
+ IOListFormat io str,ListFormat str) =>
+ StackComment str :+: str -> m ()
+execSymbolOrComment x = execSymbol (\b -> runCOCBuiltin b) outputComment $ (Comment <|> atomClass) x
+
runCOCBuiltin :: forall str io m.
(MonadSubIO io m,IsCapriconString str,
MonadStack (COCState str) str (COCBuiltin io str) (COCValue io str) m,
@@ 192,14 221,17 @@ runCOCBuiltin COCB_Print = do
_ -> return ()
runCOCBuiltin COCB_Axiom = runStackState $ modify $ \case
- StackCOC (COCExpr (ContextNode 0 e)):StackSymbol s:st -> StackCOC (COCExpr (ContextNode 0 (Cons (Ap (Axiom e s) [])))):st
+ StackCOC (COCExpr (NormalTerm (NormalType _ [] _) e)):StackSymbol s:st -> StackCOC (COCExpr (NormalTerm (NormalType 0 zero e) (Cons (Ap (Axiom e s) [])))):st
st -> st
runCOCBuiltin COCB_Format = do
ex <- runExtraState get
let format ('%':'s':s) (StackSymbol h:t) = first (h+) (format s t)
- format ('%':'v':s) (x:t) = first (showStackVal doc2raw (ex^.showDir) (ex^.context) x+) (format s t)
- format ('%':'l':s) (x:t) = first (showStackVal doc2latex (ex^.showDir) (ex^.context) x+) (format s t)
+ format ('%':'a':s) (StackSymbol h:t) = first (htmlQuote h+) (format s t)
+ format ('%':'n':s) (StackSymbol h:t) = first (markSyntax h+) (format s t)
+ format ('%':'v':s) (x:t) = first (showStackVal doc2raw (ex^.showDir) (map (second snd) (ex^.context)) x+) (format s t)
+ format ('%':'g':s) (x:t) = first (showStackVal doc2svg (ex^.showDir) (map (second snd) (ex^.context)) x+) (format s t)
+ format ('%':'l':s) (x:t) = first (showStackVal doc2latex (ex^.showDir) (map (second snd) (ex^.context)) x+) (format s t)
format (c:s) t = first (fromString [c]+) (format s t)
format "" t = ("",t)
runStackState $ modify $ \case
@@ 211,9 243,8 @@ runCOCBuiltin (COCB_Open (ReadImpl getResource)) = do
case s of
StackSymbol f:t -> do
runStackState $ put t
- xs <- liftSubIO (getResource (f+".md")) >>= maybe undefined return . matches Just literate . maybe "" toString
- let ex = execSymbol runCOCBuiltin outputComment
- ex "{" >> traverse_ ex xs >> ex "}"
+ xs <- liftSubIO (getResource (f+".md")) >>= maybe undefined return . matches Just literate . (const "" <|> toString)
+ execSymbolOrComment (Right "{") >> traverse_ execSymbolOrComment xs >> execSymbolOrComment (Right "}")
_ -> return ()
runCOCBuiltin COCB_ToInt = runStackState $ modify $ \case
@@ 242,8 273,8 @@ runCOCBuiltin COCB_Ap = do
runCOCBuiltin (COCB_Bind close bt) = do
ctx <- runExtraState (getl context)
let dctx = length ctx
- setVal (StackCOC (COCExpr e@(ContextNode d _)))
- | d==dctx || not close
+ setVal (StackCOC (COCExpr e))
+ | normalDepth e==dctx || not close
, Just e' <- runInContext ctx (mkBind bt e) = StackCOC (COCExpr e')
setVal (StackDict dict) = StackDict (map setVal dict)
setVal (StackList l) = StackList (map setVal l)
@@ 266,39 297,45 @@ runCOCBuiltin COCB_MatchTerm = do
st <- runStackState get
cctx <- runExtraState (getl context)
let tailCall v go = go >> execValue runCOCBuiltin (const unit) v
- runMatch onUniverse onLambda onProduct onApply onMu onVar onAxiom d e st' =
- case e of
- Bind Lambda x tx e' -> tailCall onLambda $ do
- runExtraState $ context =~ ((x,tx):)
- runStackState $ put (StackCOC (COCExpr (ContextNode (d+1) (Cons (Ap (Sym 0) []))))
- :StackCOC (COCExpr (ContextNode (d+1) e'))
+ runMatch onUniverse onLambda onProduct onApply onMu onVar onAxiom d u uc t e st' =
+ case (t,e) of
+ (Bind Prod _ _ te',Bind Lambda x tx e') -> tailCall onLambda $ do
+ runExtraState $ context =~ ((x,(u,tx)):)
+ runStackState $ put (StackCOC (COCExpr (NormalTerm (NormalType u (Just 0:fill Nothing uc) (raiseRefs 1 tx))
+ (Cons (Ap (Sym 0) []))))
+ :StackCOC (COCExpr (NormalTerm (NormalType (d+1) uc te') e'))
:st')
- Bind Prod x tx e' -> tailCall onProduct $ do
- runExtraState $ context =~ ((x,tx):)
- runStackState $ put (StackCOC (COCExpr (ContextNode (d+1) (Cons (Ap (Sym 0) []))))
- :StackCOC (COCExpr (ContextNode (d+1) e'))
+ (_,Bind Lambda _ _ _) -> do
+ runStackState $ put (StackCOC (COCError "Invalid non-product type for lambda-term. Something must be very wrong."):st')
+ (_,Bind Prod x tx e') -> tailCall onProduct $ do
+ runExtraState $ context =~ ((x,(u,tx)):)
+ runStackState $ put (StackCOC (COCExpr (NormalTerm (NormalType u (Just 0:fill Nothing uc) (raiseRefs 1 tx))
+ (Cons (Ap (Sym 0) []))))
+ :StackCOC (COCExpr (NormalTerm (NormalType (d+1) uc (Universe u)) e'))
:st')
- Cons (Ap h []) -> do
+ (_,Cons (Ap h [])) -> do
case h of
Sym i | (x,_):_ <- takeLast (d-i) cctx -> tailCall onVar $ runStackState $ put (StackSymbol x:st')
| otherwise -> tailCall onVar $ runStackState $ put (StackSymbol ("#"+fromString (show i)):st')
Mu ctx _ a -> do
let a' = foldl' (\e' (x,tx,_) -> Bind Lambda x tx e') (Cons a) ctx
- tailCall onMu $ runStackState $ put (StackCOC (COCExpr (ContextNode d a'))
- :st')
- Axiom t a -> tailCall onAxiom $ do
+ tailCall onMu $ runStackState $ put (StackCOC (withType a'):st')
+ Axiom ta a -> tailCall onAxiom $ do
runStackState $ put (StackSymbol a
- :StackCOC (COCExpr (ContextNode 0 t))
+ :StackCOC (COCExpr (NormalTerm (NormalType (u+1) uc (Universe u)) ta))
:st')
- Cons (Ap h args) -> tailCall onApply $ do
- runStackState $ put (StackList (map (StackCOC . COCExpr . ContextNode d) args)
- :StackCOC (COCExpr (ContextNode d (Cons (Ap h []))))
+ (_,Cons (Ap h args)) -> tailCall onApply $ do
+ runStackState $ put (StackList (map (StackCOC . withType) args)
+ :StackCOC (withType (Cons (Ap h [])))
:st')
- Universe n -> tailCall onUniverse $ runStackState $ put (StackInt n:st')
+ (_,Universe n) -> tailCall onUniverse $ runStackState $ put (StackInt n:st')
+ where withType x | Just tx <- type_of x (restrictEnv uc $ map (second snd) cctx) = COCExpr $ NormalTerm (NormalType u uc tx) x
+ withType _ = COCNull
+
case st of
- StackList [onUniverse,onLambda,onProduct,onApply,onMu,onVar,onAxiom]:StackCOC (COCExpr (ContextNode d e)):st' -> runMatch onUniverse onLambda onProduct onApply onMu onVar onAxiom d e st'
- onUniverse:onLambda:onProduct:onApply:onMu:onVar:onAxiom:StackCOC (COCExpr (ContextNode d e)):st' -> runMatch onUniverse onLambda onProduct onApply onMu onVar onAxiom d e st'
+ StackList [onUniverse,onLambda,onProduct,onApply,onMu,onVar,onAxiom]:StackCOC (COCExpr (NormalTerm (NormalType u c t) e)):st' -> runMatch onUniverse onLambda onProduct onApply onMu onVar onAxiom (length c) u c t e st'
+ onUniverse:onLambda:onProduct:onApply:onMu:onVar:onAxiom:StackCOC (COCExpr (NormalTerm (NormalType u c t) e)):st' -> runMatch onUniverse onLambda onProduct onApply onMu onVar onAxiom (length c) u c t e st'
_ -> unit
runCOCBuiltin COCB_TypeOf = do
@@ 324,17 361,15 @@ runCOCBuiltin COCB_Pull = do
| otherwise -> StackCOC COCNull:st
st -> st
-runCOCBuiltin (COCB_ExecModule (WriteImpl writeResource)) = do
+runCOCBuiltin (COCB_Redirect (WriteImpl writeResource)) = do
st <- runStackState get
case st of
StackSymbol f:StackProg p:t -> do
- old <- runDictState get
+ runStackState $ put t
oldH <- runExtraState (outputText <~ \x -> (id,x))
execProgram runCOCBuiltin outputComment p
- new <- runDictState (id <~ (old,))
newH <- runExtraState (outputText <~ \x -> (oldH,x))
liftSubIO $ writeResource f (newH "")
- runStackState $ put $ StackDict new:t
_ -> return ()
runCOCBuiltin (COCB_Cache (ReadImpl getResource) (WriteImpl writeResource)) = do
@@ 343,7 378,7 @@ runCOCBuiltin (COCB_Cache (ReadImpl getResource) (WriteImpl writeResource)) = do
StackSymbol f:StackProg p:t -> do
runStackState (put t)
liftSubIO (getResource (f+".blob")) >>= \case
- Just res | Just v <- matches Just datum res -> runStackState $ modify $ (v:)
+ Right res | Just v <- matches Just datum res -> runStackState $ modify $ (v:)
_ -> do
execProgram runCOCBuiltin outputComment p
st' <- runStackState get
@@ 383,7 418,7 @@ runCOCBuiltin COCB_ContextVars = do
runCOCBuiltin COCB_Extract = do
ctx <- runExtraState (getl context)
runStackState $ modify $ \case
- StackCOC (COCExpr (ContextNode d e)):t -> StackCOC (COCAlgebraic (fromNode e ([],takeLast d ctx))):t
+ StackCOC (COCExpr (NormalTerm (NormalType _ c _) e)):t -> StackCOC (COCAlgebraic (fromTerm e ([],map (second snd) $ takeLast (length c) ctx))):t
st -> st
runCOCBuiltin COCB_GetShowDir = do
@@ 400,11 435,28 @@ runCOCBuiltin COCB_SetShowDir = do
runCOCBuiltin COCB_InsertNodeDir = do
ctx <- runExtraState (getl context)
runStackState $ modify $ \case
- x:StackCOC (COCExpr (ContextNode d e)):StackCOC (COCDir dir):t ->
- StackCOC (COCDir (insert e (map fst (takeLast d ctx),x) dir)):t
+ x:StackCOC (COCExpr (NormalTerm (NormalType _ c _) e)):StackCOC (COCDir dir):t ->
+ StackCOC (COCDir (insert e (map fst (takeLast (length c) ctx),x) dir)):t
st -> st
-cocDict :: forall io str. IsCapriconString str => str -> (str -> io (Maybe str)) -> (str -> io (Maybe [Word8])) -> (str -> str -> io ()) -> (str -> [Word8] -> io ()) -> COCDict io str
+runCOCBuiltin COCB_Render = runStackState $ modify $ \case
+ StackProg p:st -> StackProg (foldMap renderStep p):st
+ st -> st
+ where renderStep (VerbStep v) = [VerbStep v]
+ renderStep (ExecStep x) = [ExecStep x]
+ renderStep (ConstStep c) = [ConstStep c]
+ renderStep (CommentStep c) = renderComment c
+ renderStep (ClosureStep closed cl) = [ClosureStep closed (renderClos cl)]
+ renderClos (StackClosure act ps pt) = StackClosure act [(foldMap renderStep p,renderClos cl)
+ | (p,cl) <- ps] (foldMap renderStep pt)
+
+renderComment (TextComment s) = [ConstStep (StackSymbol s), VerbStep "comment"]
+renderComment (BeginCodeParagraph l code exs) = [ConstStep (StackInt l),ConstStep (StackSymbol code),ConstStep (StackList (map StackSymbol exs)), VerbStep "begin-code-paragraph"]
+renderComment EndCodeParagraph = [VerbStep "end-code-paragraph"]
+renderComment (BeginCodeSpan s) = [ConstStep (StackSymbol s),VerbStep "begin-code-span"]
+renderComment (EndCodeSpan s) = [ConstStep (StackSymbol s),VerbStep "end-code-span"]
+
+cocDict :: forall io str. IsCapriconString str => str -> (str -> io (String :+: str)) -> (str -> io (String :+: [Word8])) -> (str -> str -> io ()) -> (str -> [Word8] -> io ()) -> COCDict io str
cocDict version getResource getBResource writeResource writeBResource =
mkDict ((".",StackProg []):("steps.",StackProg []):("mustache.",StackProg []):("version",StackSymbol version):
[(x,StackBuiltin b) | (x,b) <- [
@@ 413,8 465,11 @@ cocDict version getResource getBResource writeResource writeBResource =
("lookup" , Builtin_Lookup ),
("exec" , Builtin_Exec ),
("quote" , Builtin_Quote ),
+ ("vocabulary" , Builtin_CurrentDict ),
+ ("set-vocabulary" , Builtin_SetCurrentDict ),
("stack" , Builtin_Stack ),
+ ("set-stack" , Builtin_SetStack ),
("clear" , Builtin_Clear ),
("shift" , Builtin_Shift ),
("shaft" , Builtin_Shaft ),
@@ 425,6 480,7 @@ cocDict version getResource getBResource writeResource writeBResource =
("swap" , Builtin_Swap ),
("swapn" , Builtin_SwapN ),
("pick" , Builtin_Pick ),
+ ("pre-render" , Builtin_Extra COCB_Render ),
("[" , Builtin_ListBegin ),
("]" , Builtin_ListEnd ),
@@ 433,7 489,8 @@ cocDict version getResource getBResource writeResource writeBResource =
("io/print" , Builtin_Extra COCB_Print ),
("io/source" , Builtin_Extra (COCB_Open (ReadImpl getResource))),
("io/cache" , Builtin_Extra (COCB_Cache (ReadImpl getBResource) (WriteImpl writeBResource))),
-
+ ("io/redirect" , Builtin_Extra (COCB_Redirect (WriteImpl writeResource))),
+
("string/format" , Builtin_Extra COCB_Format ),
("string/to-int" , Builtin_Extra COCB_ToInt ),
@@ 446,14 503,13 @@ cocDict version getResource getBResource writeResource writeBResource =
("list/each" , Builtin_Each ),
("list/range" , Builtin_Range ),
+ ("list/cons" , Builtin_Cons ),
- ("dict/vocabulary" , Builtin_CurrentDict ),
("dict/empty" , Builtin_Empty ),
("dict/insert" , Builtin_Insert ),
("dict/delete" , Builtin_Delete ),
("dict/keys" , Builtin_Keys ),
- ("dict/module" , Builtin_Extra (COCB_ExecModule (WriteImpl writeResource))),
-
+
("term-index/pattern-index" , Builtin_Extra COCB_GetShowDir ),
("term-index/set-pattern-index" , Builtin_Extra COCB_SetShowDir ),
("term-index/index-insert" , Builtin_Extra COCB_InsertNodeDir ),
@@ 488,24 544,20 @@ cocDict version getResource getBResource writeResource writeBResource =
atP (h,[]) = at h
atP (h,x:t) = at h.l'Just (StackDict zero).t'StackDict.atP (x,t)
-outputComment c = (runExtraState $ do outputText =~ (\o t -> o (commentText+t)))
- where commentText = case toString c of
- 'r':'b':p:[] -> let x = if p=='p' then "paragraph" else ""
- tag = if p=='p' then "div" else "span"
- in "<"+tag+" class=\"capricon-"+x+"result\">"
- 'r':'e':p:[] -> "</"+(if p=='p' then "div" else "span")+">"
- 'c':'p':_ -> let nlines = length (lines (toString c))
- in wrapStart True nlines+"<div class=\"capricon-steps\"><pre class=\"capricon capricon-paragraph capricon-context\">"
- +htmlQuote (drop 2 c)+"</pre>"+userInput+"</div>"+wrapEnd
- 'c':'s':_ -> wrapStart False 1+"<code class=\"capricon\">"+htmlQuote (drop 2 c)+"</code>"+wrapEnd
- 's':_ -> drop 1 c
- _ -> ""
-
- wrapStart isP nlines =
- let hide = if isP then "hideparagraph" else "hidestache"
- in "<label class=\"hide-label\"><input type=\"checkbox\" class=\"capricon-hide\" checked=\"checked\"/><span class=\"capricon-"
- + hide +"\"></span><span class=\"capricon-reveal\" data-linecount=\""
- + fromString (show nlines)+"\">"
- wrapEnd = "</span></label>"
- userInput = "<div class=\"user-input\"><button class=\"capricon-trigger\">Open/Close console</button><span class=\"capricon-input-prefix\">Evaluate in this context (press Enter to run):</span><input type=\"text\" class=\"capricon-input\" /><pre class=\"capricon-output\"></pre></div>"
-
+outputComment :: forall str io m.
+ (MonadSubIO io m,IsCapriconString str,
+ MonadStack (COCState str) str (COCBuiltin io str) (COCValue io str) m,
+ IOListFormat io str,ListFormat str) =>
+ StackComment str -> m ()
+outputComment c = execProgram runCOCBuiltin (\_ -> unit) (renderComment c)
+
+markSyntax str = fold [if isWord then
+ let qw = htmlQuote w
+ withSpans | w=="{" = \x -> "<span class=\"quote quote-brace\">"+x
+ | w==",{" = \x -> "<span class=\"quote quote-splice\">"+x
+ | w=="${" = \x -> "<span class=\"quote quote-exec\">"+x
+ | w=="}" = \x -> x+"</span>"
+ | otherwise = \x -> x
+ in withSpans ("<span class=\"symbol\" data-symbol-name=\""+qw+"\">"+qw+"</span>")
+ else w
+ | (isWord,w) <- stringWordsAndSpaces False str]
M capricon/src/Data/CaPriCon.hs => capricon/src/Data/CaPriCon.hs +237 -152
@@ 1,14 1,19 @@
{-# LANGUAGE UndecidableInstances, OverloadedStrings, NoMonomorphismRestriction, DeriveGeneric, ConstraintKinds #-}
module Data.CaPriCon(
-- * Expression nodes
- IsCapriconString(..),BindType(..),Node(..),ApHead(..),Application(..),ContextNode(..),Env,COCExpression(..),
+ -- ** Raw unchecked terms
+ IsCapriconString(..),BindType(..),Term(..),ApHead(..),Application(..),type_of,
-- ** Managing De Bruijin indices
- adjust_depth,adjust_telescope_depth,inc_depth,free_vars,is_free_in,
+ restrictEnv,adjustRefs,telescope_adjustRefs,raiseRefs,mapUnivs,freeRefs,isFreeIn,
+ -- ** Normal terms and their logic
+ NormalType(..),NormalTerm(..),normalDepth,normalUniv,Env,DependentLogic(..),
-- ** Expression directories
StringPattern,NodeDir(..),AHDir(..),ApDir,
findPattern,freshContext,
-- * Showing nodes
- ListBuilder(..),NodeDoc(..),doc2raw,doc2latex,showNode,showNode'
+ ListBuilder(..),NodeDoc(..),doc2raw,doc2latex,doc2svg,showNode,showNode',
+ -- * Wishful thinking
+ Prismatic(..),Ray(..),Reflection(..),toPrismatic
) where
import Definitive
@@ 46,35 51,53 @@ instance SerialStream ListStream where
encodeByte _ b = ListBuilder (b:)
toSerialStream (ListBuilder k) = k []
--- | Inductive types
+
+
+-- | types
type UniverseSize = Int
type SymbolRef = Int
data BindType = Lambda | Prod
deriving (Show,Eq,Ord,Generic)
-data Node str a = Bind BindType str (NodeType str a) (Node str a)
+data Term str a = Bind BindType str (TypeTerm str a) (Term str a)
| Cons (Application str a)
| Universe UniverseSize
deriving (Show,Generic)
-type NodeType str a = Node str a
-data ApHead str a = Sym SymbolRef | Mu [(str,Node str a,Node str a)] [Node str a] (Application str a) | Axiom (Node str a) a
+type TypeTerm str a = Term str a
+data ApHead str a = Sym SymbolRef
+ | Mu [(str,TypeTerm str a,TypeTerm str a)] [Term str a] (Application str a)
+ | Axiom (Term str a) a
deriving (Show,Generic)
-data Application str a = Ap (ApHead str a) [Node str a]
+data Application str a = Ap (ApHead str a) [Term str a]
deriving (Show,Generic)
-type Env str a = [(str,NodeType str a)]
+
+data Prismatic str a = Prism_Lens (Ray UniverseSize str a) (Prismatic str a)
+ | Prism_Ray (Ray (SymbolRef,[Term str a]) str a) (Prismatic str a)
+ | Prism_Base SymbolRef [Term str a]
+data Ray tail str a = Ray_Param (Reflection str a) (Ray tail str a)
+ | Ray_Tail tail
+data Reflection str a = Refl_Base SymbolRef [Term str a]
+ | Refl_Param (Term str a) (Reflection str a)
+ | Refl_Rec (Ray (Term str a) str a) (Reflection str a)
+
+-- | TODO : make this function return something
+toPrismatic :: TypeTerm str a -> Maybe (Prismatic str a)
+toPrismatic _ = Nothing
type ListSerializable a = (Serializable ListStream a)
type ListFormat a = (Format ListStream a)
instance ListSerializable BindType
instance ListFormat BindType
-instance (ListSerializable a,ListSerializable str) => ListSerializable (Node str a)
-instance (ListFormat a,ListFormat str) => ListFormat (Node str a)
+instance (ListSerializable a,ListSerializable str) => ListSerializable (Term str a)
+instance (ListFormat a,ListFormat str) => ListFormat (Term str a)
instance (ListSerializable a,ListSerializable str) => ListSerializable (ApHead str a)
instance (ListFormat a,ListFormat str) => ListFormat (ApHead str a)
instance (ListSerializable a,ListSerializable str) => ListSerializable (Application str a)
instance (ListFormat a,ListFormat str) => ListFormat (Application str a)
-class Monad m => COCExpression str m e | e -> str where
+type Env str e = [(str,Binding e)]
+class Monad m => DependentLogic str m e | e -> str where
type Axiom e :: *
+ type Binding e :: *
mkUniverse :: UniverseSize -> m e
mkVariable :: str -> m e
@@ 84,98 107,114 @@ class Monad m => COCExpression str m e | e -> str where
checkType :: e -> m e
conversionDelta :: e -> e -> m (UniverseSize,UniverseSize)
- substHyp :: str -> e -> m (e -> e,Env str (Axiom e))
+ substHyp :: str -> e -> m (e -> e,Env str e)
pullTerm :: Maybe str -> e -> m e
- insertHypBefore :: Maybe str -> str -> e -> m (e -> e,Env str (Axiom e))
-instance (Show a,IsCapriconString str,Monad m,MonadReader (Env str a) m) => COCExpression str (MaybeT m) (Node str a) where
- type Axiom (Node str a) = a
-
- mkUniverse = pure . Universe
- mkVariable v = hypIndex v <&> \i -> Cons (Ap (Sym i) [])
- mkBind b e = ask >>= \case
- (x,tx):_ -> pure $ Bind b x tx e
- _ -> zero
- mkApply f x = return (subst f (Cons (Ap (Sym 0) [inc_depth 1 x])))
- mkMu e = do
- te <- checkType e
- mte <- mu_type te^.maybeT
- let args (Bind Prod _ tx e') = tx:args e'
- args _ = []
- return (subst e (Cons (Ap (Mu [] (args mte) (Ap (Sym 0) [])) [])))
- checkType e = type_of e^.maybeT
- conversionDelta a b = return (convertible a b)^.maybeT
-
- substHyp h x = do
- i <- hypIndex h
- lift $ do
- ctx <- ask
- return (substn x i,let (ch,ct) = splitAt i ctx in zipWith (\j -> second $ substn (inc_depth (negate (1+j)) x) (i-j-1)) [0..] ch+drop 1 ct)
- pullTerm _ = return
- insertHypBefore Nothing h th = lift $ do
- ctx <- ask
- return (inc_depth 1,(h,th):ctx)
- insertHypBefore (Just h) h' th' = do
- hi <- hypIndex h
- lift $ do
- ctx <- ask
- let adj i j = if i+j>=hi then j+1 else j
- return (
- adjust_depth (adj (-1)),
- foldr (\x k i -> case compare hi i of
- LT -> x:k (i+1)
- EQ -> second (adjust_depth (adj i)) x:(h',inc_depth (negate (hi+1)) th'):k (i+1)
- GT -> second (adjust_depth (adj i)) x:k (i+1))
- (\_ -> []) ctx 0)
-
-hypIndex :: (IsCapriconString str,MonadReader (Env str a) m) => str -> MaybeT m Int
+ insertHypBefore :: Maybe str -> str -> e -> m (e -> e,Env str e)
+
+data NormalType str a = NormalType UniverseSize [Maybe UniverseSize] (TypeTerm str a)
+ deriving (Show,Generic)
+data NormalTerm str a = NormalTerm (NormalType str a) (Term str a)
+ deriving (Show,Generic)
+instance (ListSerializable a,ListSerializable str) => ListSerializable (NormalType str a)
+instance (ListSerializable a,ListSerializable str) => ListSerializable (NormalTerm str a)
+instance (ListFormat a,ListFormat str) => ListFormat (NormalType str a)
+instance (ListFormat a,ListFormat str) => ListFormat (NormalTerm str a)
+
+normalDepth :: NormalTerm str a -> Int
+normalDepth (NormalTerm (NormalType _ c _) _) = length c
+normalUniv :: NormalTerm str a -> UniverseSize
+normalUniv (NormalTerm (NormalType u _ _) _) = u
+
+normal_raiseRefs :: Int -> NormalTerm str a -> NormalTerm str a
+normal_raiseRefs 0 x = x
+normal_raiseRefs n (NormalTerm (NormalType u uc t) e) = NormalTerm (NormalType u ((if n>0 then (take n (repeat Nothing)+) else drop (-n)) uc) (raiseRefs n t)) (raiseRefs n e)
+
+restrictEnv :: [b] -> [a] -> [a]
+restrictEnv n e = drop (length e-length n) e
+hypIndex :: (IsCapriconString str,MonadReader [(str,a)] m) => str -> MaybeT m Int
hypIndex h = ask >>= \l -> case [i | (i,x) <- zip [0..] l, fst x==h] of
i:_ -> return i
_ -> zero
-
-data ContextNode str a = ContextNode SymbolRef (Node str a)
- deriving (Show,Generic)
-instance (ListSerializable a,ListSerializable str) => ListSerializable (ContextNode str a)
-instance (ListFormat a,ListFormat str) => ListFormat (ContextNode str a)
-restrictEnv :: SymbolRef -> Env str a -> Env str a
-restrictEnv n e = drop (length e-n) e
-
-instance (Show a,IsCapriconString str,MonadReader (Env str a) m,Monad m) => COCExpression str (MaybeT m) (ContextNode str a) where
- type Axiom (ContextNode str a) = a
-
- mkUniverse u = ask >>= \ctx -> ContextNode (length ctx)<$>mkUniverse u
- mkVariable i = local (dropWhile ((/=i) . fst)) (ask >>= \ctx -> ContextNode (length ctx)<$>mkVariable i)
- mkBind t ce@(ContextNode de e) | de>0 = ContextNode (de-1) <$> local (restrictEnv de) (mkBind t e)
- | otherwise = return ce
- mkApply (ContextNode df f) (ContextNode dx x) = do
- let dm = max df dx
- ContextNode dm <$> mkApply (inc_depth (dm-df) f) (inc_depth (dm-dx) x)
- mkMu (ContextNode d e) = ContextNode d <$> local (restrictEnv d) (mkMu e)
- checkType (ContextNode d e) = ContextNode d <$> local (restrictEnv d) (checkType e)
- conversionDelta (ContextNode da a) (ContextNode db b) =
- let dm = max da db in
- local (restrictEnv dm)
- $ conversionDelta (inc_depth (dm-da) a) (inc_depth (dm-db) b)
+
+instance (Show a,IsCapriconString str,MonadReader (Env str (NormalTerm str a)) m,Monad m) => DependentLogic str (MaybeT m) (NormalTerm str a) where
+ type Axiom (NormalTerm str a) = a
+ type Binding (NormalTerm str a) = (UniverseSize,TypeTerm str a)
+
+ mkUniverse u = return $ NormalTerm (NormalType (u+2) [] (Universe (u+1))) (Universe u)
+ mkVariable h = local (dropWhile ((/=h) . fst)) $ ask >>= \case
+ (_,(u,t)):hs -> return $ NormalTerm (NormalType u (Just 0:fill Nothing hs) (raiseRefs 1 t)) (Cons (Ap (Sym 0) []))
+ _ -> zero
+ mkBind shape (NormalTerm (NormalType u cs@(c:ct) t) e) = local (restrictEnv cs) $ ask >>= \case
+ (x,(ux,tx)):_ -> return $ NormalTerm (NormalType (max u ux) ct
+ (case shape of
+ Lambda -> Bind Prod x (maybe id raiseUnivs c tx) t
+ Prod -> Universe (max u ux)))
+ (Bind shape x tx e)
+ _ -> zero
+ mkBind _ ce = return ce
+ mkApply jf jx = do
+ let df = normalDepth jf ; dx = normalDepth jx
+ dm = max df dx
+ NormalTerm (NormalType uf cf tf) f = normal_raiseRefs (dm-df) jf
+ NormalTerm (NormalType ux cx tx) x = normal_raiseRefs (dm-dx) jx
+ tr <- case tf of
+ Bind Prod _ tx' tr | Just _ <- unifyTerms tx tx' -> return $ subst x tr
+ _ -> zero
+ return $
+ NormalTerm (NormalType (max uf ux) (zipWith (\a b -> zipWith max a b + a + b) cf cx) tr)
+ (subst f (Cons (Ap (Sym 0) [raiseRefs 1 x])))
+ mkMu (NormalTerm (NormalType u c t) e) = local (restrictEnv c) $ do
+ mt <- (ask >>= return . (mu_type t) . map (second snd))^.maybeT
+ let args (Bind Prod _ tx e') = tx:args e'
+ args _ = []
+ me = subst e (Cons (Ap (Mu [] (args mt) (Ap (Sym 0) [])) []))
+ return $ NormalTerm (NormalType (u+1) c (subst e mt)) me
+ checkType (NormalTerm (NormalType u c t) _) = return $ NormalTerm (NormalType (u+1) c (Universe u)) t
+ conversionDelta na@(NormalTerm _ a) nb@(NormalTerm _ b) =
+ let dm = max da db
+ da = normalDepth na ; db = normalDepth nb
+ in return (unifyTerms (raiseRefs (dm-da) a) (raiseRefs (dm-db) b))^.maybeT
- pullTerm Nothing (ContextNode d e) = ask <&> \l -> ContextNode (length l) (inc_depth (length l-d) e)
- pullTerm (Just v) (ContextNode d e) = do
+ pullTerm Nothing x = ask <&> \l -> normal_raiseRefs (length l - normalDepth x) x
+ pullTerm (Just v) x@(NormalTerm _ e) = do
nctx <- length <$> ask
i <- hypIndex v
- let d' = nctx-(i+1)
- guard (d'>=d || all (\j -> d'+j >= d) (free_vars e))
- return (ContextNode d' $ inc_depth (d'-d) e)
-
- substHyp h vh = do
- ContextNode dm vh' <- pullTerm (Just h) vh
- first (\f cv@(ContextNode d v) ->
- if d <= dm then cv
- else ContextNode (d-1) (inc_depth (d-dm) $ f $ inc_depth (dm-d) v)) <$>
- substHyp h vh'
- insertHypBefore h h' cth' = do
- ContextNode dh th' <- pullTerm h cth'
- first (\f cx@(ContextNode d x) ->
- if d <= dh then cx
- else ContextNode (d+1) (inc_depth (d-dh) $ f $ inc_depth (dh-d) x))
- <$> insertHypBefore h h' th'
+ let d' = nctx-(i+1) ; d = normalDepth x
+ guard (d'>=d || all (\j -> d'+j >= normalDepth x) (freeRefs e))
+ return $ normal_raiseRefs (d'-d) x
+
+ substHyp h nx = do
+ NormalTerm (NormalType ux cx _) x <- pullTerm (Just h) nx
+ ctx <- ask
+ i <- hypIndex h
+ let newEnv =
+ let (ch,ct) = splitAt i ctx
+ in zipWith (\j -> second $ second $ substn (raiseRefs (negate (1+j)) x) (i-j-1)) [0..] ch+drop 1 ct
+ dx = length cx ; dm = length ctx
+ return (liftUpdate dm dx ux cx (substn x i),newEnv)
+ insertHypBefore bef h nth = do
+ NormalTerm (NormalType uth cth _) th <- pullTerm bef nth
+ ctx <- ask
+ let upd = liftUpdate (length ctx) (length cth) uth cth
+ case bef of
+ Nothing -> return (upd (raiseRefs 1) , (h,(normalUniv nth-1,th)):ctx)
+ Just hb -> do
+ hbi <- hypIndex hb
+ let adj i j = if i+j>=hbi then j+1 else j
+ return (
+ upd (adjustRefs (adj (-1))),
+ foldr (\x k i -> case compare hbi i of
+ LT -> x:k (i+1)
+ EQ -> second (second (adjustRefs (adj i))) x:(h,(uth,raiseRefs (negate (hbi+1)) th)):k (i+1)
+ GT -> second (second (adjustRefs (adj i))) x:k (i+1))
+ (\_ -> []) ctx 0)
+
+liftUpdate dm dx ux cx f ny@(NormalTerm (NormalType uy cy ty) y)
+ | normalDepth ny<=dx = ny
+ | otherwise = let dy = normalDepth ny in
+ NormalTerm (NormalType (max ux uy) (zipWith (\a b -> zipWith max a b + a + b) (cx+repeat Nothing) cy)
+ (raiseRefs (dy-dm) $ f $ raiseRefs (dm-dy) ty))
+ (raiseRefs (dy-dm) $ f $ raiseRefs (dm-dy) y)
data NodeDir str ax a = NodeDir
(Map BindType (NodeDir str ax (NodeDir str ax a)))
@@ 227,7 266,7 @@ i'Cofree = iso (uncurry Step) (\(Step x y) -> (x,y))
instance Ord ax => Semigroup (NodeDir str ax a) where NodeDir a b c + NodeDir a' b' c' = NodeDir (a+a') (b+b') (c+c')
instance Ord ax => Monoid (NodeDir str ax a) where zero = NodeDir zero zero zero
-instance Ord ax => DataMap (NodeDir str ax a) (Node str ax) a where
+instance Ord ax => DataMap (NodeDir str ax a) (Term str ax) a where
at (Bind t _ tx e) = from i'NodeDir.l'1.at t.l'Just zero.at tx.l'Just zero.at e
at (Cons a) = from i'NodeDir.l'2.atAp a
at (Universe u) = from i'NodeDir.l'3.at u
@@ 250,11 289,11 @@ mayChoose Nothing = zero
(<++>) :: WriterT w [] a -> WriterT w [] a -> WriterT w [] a
a <++> b = a & from writerT %~ (+ b^..writerT)
-findPattern :: Ord ax => NodeDir str ax a -> Node str ax -> [([([(str,Node str ax)],Int,Node str ax)],a)]
+findPattern :: Ord ax => NodeDir str ax a -> Term str ax -> [([([(str,Term str ax)],Int,Term str ax)],a)]
findPattern = \x y -> go [] x y^..writerT
- where go :: Ord ax => [(str,Node str ax)] -> NodeDir str ax a -> Node str ax -> WriterT [([(str,Node str ax)],Int,Node str ax)] [] a
- go_a :: Ord ax => [(str,Node str ax)] -> ApDir str ax a -> Application str ax -> WriterT [([(str,Node str ax)],Int,Node str ax)] [] a
- go_ah :: Ord ax => [(str,Node str ax)] -> AHDir str ax a -> ApHead str ax -> WriterT [([(str,Node str ax)],Int,Node str ax)] [] a
+ where go :: Ord ax => [(str,Term str ax)] -> NodeDir str ax a -> Term str ax -> WriterT [([(str,Term str ax)],Int,Term str ax)] [] a
+ go_a :: Ord ax => [(str,Term str ax)] -> ApDir str ax a -> Application str ax -> WriterT [([(str,Term str ax)],Int,Term str ax)] [] a
+ go_ah :: Ord ax => [(str,Term str ax)] -> AHDir str ax a -> ApHead str ax -> WriterT [([(str,Term str ax)],Int,Term str ax)] [] a
withEnv env d x m = foldr (\(i,as) ma -> ma <++> (foldl'.foldl') (\l a -> (tell [(env,i-length env,x)] >> return a) <++> l) zero as)
m (d^??from i'NodeDir.l'2.from i'AHDir.l'1.ascList.each.sat ((>=length env) . fst))
go env d wh@(Bind t x tx e) = withEnv env d wh $ do
@@ 278,7 317,7 @@ findPattern = \x y -> go [] x y^..writerT
d' <- mayChoose (d^.from i'AHDir.l'2.at (length tenv))
go_a env d' a
--- `adjust_depth f e` produces an expression `e'` whose variables (de
+-- `adjustRefs f e` produces an expression `e'` whose variables (de
-- Bruijin indices) are adjusted from `e` by the function `f`.
--
-- `f` takes two arguments `i` and `d`, where `i` is the previous
@@ 286,10 325,10 @@ findPattern = \x y -> go [] x y^..writerT
-- (the number of binders between the top-level and the node in
-- question).
--
- -- For example, `adjust_depth (\i d -> i-d+1) (Bind Lambda "x" (Universe 0) (Cons (Ap (Sym 1) [])))
+ -- For example, `adjustRefs (\i d -> i-d+1) (Bind Lambda "x" (Universe 0) (Cons (Ap (Sym 1) [])))
-- == Bind Lambda "x" (Universe 0) (Cons (Ap (Sym 2) []))`
-adjust_depth f = go 0
+adjustRefs f = go 0
where go d (Bind t x tx e) = Bind t x (go d tx) (go (d+1) e)
go _ (Universe u) = Universe u
go d (Cons a) = Cons (go_a d a)
@@ 301,31 340,41 @@ adjust_depth f = go 0
(go_a (d+length env) a')) (map (go d) subs)
go_a d (Ap x@(Axiom _ _) subs) = Ap x (map (go d) subs)
-inc_depth 0 = \x -> x
-inc_depth dx = adjust_depth (+dx)
-adjust_telescope_depth field f = zipWith (field . adjust_depth . \i j -> if j<i then j else i+f (j-i)) [0..]
-free_vars :: Node str a -> Set Int
-free_vars (Bind _ _ tx e) = free_vars tx + delete (-1) (map (subtract 1) (free_vars e))
-free_vars (Cons a) = freeA a
- where freeA (Ap (Sym i) xs) = singleton' i + foldMap free_vars xs
- freeA (Ap (Mu env _ a') xs) = foldMap free_vars xs +
- map (subtract envS) (freeA a' - fromKList [0..envS-1])
- where envS = length env
- freeA (Ap (Axiom _ _) xs) = foldMap free_vars xs
-free_vars _ = zero
-
-is_free_in :: Int -> Node str a -> Bool
-is_free_in = map2 not go
+isFreeIn :: Int -> Term str a -> Bool
+isFreeIn = map2 not go
where go v (Bind _ _ t e) = go v t && go (v+1) e
go v (Cons a) = go_a v a
go _ (Universe _) = True
go_a v (Ap (Sym v') subs) = v/=v' && all (go v) subs
go_a v (Ap (Mu env _ a) subs) = go_a (v+length env) a && all (go v) subs
go_a v (Ap (Axiom _ _) subs) = all (go v) subs
-
-subst :: (Show str,Show a) => Node str a -> Node str a -> Node str a
+
+raiseRefs 0 = \x -> x
+raiseRefs dx = adjustRefs (+dx)
+telescope_adjustRefs field f = zipWith (field . adjustRefs . \i j -> if j<i then j else i+f (j-i)) [0..]
+freeRefs :: Term str a -> Set SymbolRef
+freeRefs (Bind _ _ tx e) = freeRefs tx + delete (-1) (map (subtract 1) (freeRefs e))
+freeRefs (Cons a) = freeA a
+ where freeA (Ap (Sym i) xs) = singleton' i + foldMap freeRefs xs
+ freeA (Ap (Mu env _ a') xs) = foldMap freeRefs xs +
+ map (subtract envS) (freeA a' - fromKList [0..envS-1])
+ where envS = length env
+ freeA (Ap (Axiom _ _) xs) = foldMap freeRefs xs
+freeRefs _ = zero
+
+mapUnivs f = go
+ where go (Bind t x tx e) = Bind t x (go tx) (go e)
+ go (Universe u) = Universe (f u)
+ go (Cons a) = Cons (go_a a)
+ go_a (Ap h subs) = Ap (go_ah h) (map go subs)
+ go_ah (Mu e t a) = Mu (map (\(x,y,z) -> (x,go y,go z)) e) (map go t) (go_a a)
+ go_ah (Axiom t a) = Axiom (go t) a
+ go_ah x = x
+raiseUnivs n = mapUnivs (+n)
+
+subst :: (Show str,Show a) => Term str a -> Term str a -> Term str a
subst = flip substn 0
-substn :: (Show str,Show a) => Node str a -> Int -> Node str a -> Node str a
+substn :: (Show str,Show a) => Term str a -> Int -> Term str a -> Term str a
substn val n | n>=0 = getId . go n
| otherwise = error "'subst' should not be called with a negative index"
where go d (Bind t x tx e) = do
@@ 336,7 385,7 @@ substn val n | n>=0 = getId . go n
go_a d (Ap (Sym i) xs) = traverse (go d) xs >>= \xs' ->
case compare i d of
- EQ -> rec_subst xs' (inc_depth d val)
+ EQ -> rec_subst xs' (raiseRefs d val)
LT -> return $ Cons $ Ap (Sym i) xs'
GT -> return $ Cons $ Ap (Sym (i-1)) xs'
go_a d (Ap (Mu e t a) xs) = do
@@ 356,8 405,8 @@ substn val n | n>=0 = getId . go n
let envS = length env
muEnv = reverse $ map (by l'3) env
a' <- Cons . Ap (Sym i) <$>
- sequence (fold [if nonempty (free_vars x - fromKList [0..envS-1])
- then [ return $ inc_depth envS $ foldl' (\e (x',tx,_) -> Bind Lambda x' tx e) x env
+ sequence (fold [if nonempty (freeRefs x - fromKList [0..envS-1])
+ then [ return $ raiseRefs envS $ foldl' (\e (x',tx,_) -> Bind Lambda x' tx e) x env
, return $ subst x (Cons (Ap (Mu [] muEnv (Ap (Sym 0) [])) [Cons (Ap (Sym j) []) | j <- reverse [1..envS]]))]
else [return x]
| x <- xs])
@@ 379,6 428,7 @@ data NodeDoc str = DocSeq [NodeDoc str]
| DocParen (NodeDoc str)
| DocMu (NodeDoc str)
| DocSubscript (NodeDoc str) (NodeDoc str)
+ | DocSuperscript (NodeDoc str) (NodeDoc str)
| DocAssoc str (NodeDoc str)
| DocVarName str
| DocText str
@@ 393,6 443,7 @@ instance Functor NodeDoc where
map f (DocParen x) = DocParen (map f x)
map f (DocMu x) = DocMu (map f x)
map f (DocSubscript x y) = DocSubscript (map f x) (map f y)
+ map f (DocSuperscript x y) = DocSuperscript (map f x) (map f y)
map f (DocAssoc v x) = DocAssoc (f v) (map f x)
map f (DocText x) = DocText (f x)
map f (DocVarName x) = DocVarName (f x)
@@ 405,6 456,7 @@ doc2raw (DocSeq l) = fold (map doc2raw l)
doc2raw (DocParen p) = "("+doc2raw p+")"
doc2raw (DocMu m) = "μ("+doc2raw m+")"
doc2raw (DocSubscript v x) = doc2raw v+doc2raw x
+doc2raw (DocSuperscript v x) = doc2raw v+"^"+doc2raw x
doc2raw (DocAssoc x v) = "("+x+" : "+doc2raw v+")"
doc2raw DocArrow = " -> "
doc2raw (DocText x) = x
@@ 416,12 468,40 @@ doc2latex (DocSeq l) = fold (map doc2latex l)
doc2latex (DocParen p) = "("+doc2latex p+")"
doc2latex (DocMu m) = "\\mu("+doc2latex m+")"
doc2latex (DocSubscript v x) = doc2latex v+"_{"+doc2latex x+"}"
+doc2latex (DocSuperscript v x) = doc2latex v+"^{"+doc2latex x+"}"
doc2latex (DocAssoc x v) = "("+latexName x+":"+doc2latex v+")"
doc2latex DocArrow = " \\rightarrow "
doc2latex (DocText x) = x
doc2latex (DocVarName x) = latexName x
doc2latex DocSpace = "\\,"
+doc2svg :: IsCapriconString str => NodeDoc str -> str
+doc2svg = \x -> snd $ (go x^.from state) (0::Double)
+ where
+ sym s = get >>= \x -> if x == 0 then return s
+ else ("<tspan dy=\""+fromString (show x)+"em\">"+s+"</tspan>") <$ put 0
+ go (DocSeq l) = fold<$>traverse go l
+ go (DocParen p) = liftA3 (\x y z -> x+y+z) (sym "(") (go p) (sym ")")
+ go (DocMu m) = liftA3 (\x y z -> x+y+z) (sym "μ(") (go m) (sym ")")
+ go (DocSubscript v x) = sub (go v) (go x)
+ go (DocSuperscript v x) = super (go v) (go x)
+ go (DocAssoc x v) = fold<$>sequence [sym "(",svgName x,sym ":",go v,sym ")"]
+ go DocArrow = sym " → "
+ go (DocText x) = sym x
+ go (DocVarName x) = svgName x
+ go DocSpace = sym " "
+
+ super mv mx = liftA2 (\x y -> x+"<tspan dy=\"-0.5em\"><tspan class=\"small\">"+y+"</tspan></tspan>") mv (mx <* put (0.5))
+ sub mv mx = liftA2 (\x y -> x+"<tspan dy=\"0.3em\"><tspan class=\"small\">"+y+"</tspan></tspan>") mv (mx <* put (-0.3))
+
+ svgName s = map (\x -> "<tspan class=\"variable\">"+x+"</tspan>") $ nm $ toString s
+ where nm ('.':t) = super (nm t) (sym "P")
+ nm x =
+ let (n,y) = span (\c -> c>='0' && c<='9') (reverse x) in
+ case n of
+ "" -> sym (fromString (reverse y))
+ _ -> sub (sym (fromString (reverse y))) (sym (fromString (reverse n)))
+
latexName :: IsCapriconString str => str -> str
latexName s = fromString $ go $ toString s
where go ('.':t) = go t+"^P"
@@ 431,30 511,30 @@ latexName s = fromString $ go $ toString s
_ -> "_{"+n+"}"
showNode = showNode' zero
-showNode' :: (IsCapriconString str,Show ax,Ord ax) => NodeDir str ax ([str],StringPattern str) -> [(str,Node str ax)] -> Node str ax -> NodeDoc str
+showNode' :: (IsCapriconString str,Show ax,Ord ax) => NodeDir str ax ([str],StringPattern str) -> [(str,Term str ax)] -> Term str ax -> NodeDoc str
showNode' dir = go 0
where go d env x | Just ret <- toPat d env x = ret
go _ _ (Universe u) = DocSubscript "Set" (fromString (show u))
- go d env whole@(Bind t aname atype body) | t == Lambda || 0`is_free_in`body = par 0 d $ DocSeq (DocText (bind_head t):drop 1 (bind_tail env whole))
+ go d env whole@(Bind t aname atype body) | t == Lambda || 0`isFreeIn`body = par 0 d $ DocSeq (DocText (bind_head t):drop 1 (bind_tail env whole))
| otherwise = par 0 d $ DocSeq [go 1 env atype,DocArrow,go 0 ((aname,atype):env) body]
where bind_head Lambda = "λ"
bind_head Prod = "∀"
bind_sep Prod = "," ; bind_sep Lambda = "."
bind_tail env' x | Just ret <- toPat 0 (env'+env) x = [bind_sep t,DocSpace,ret]
- bind_tail env' (Bind t' x tx e) | t==t' && (t==Lambda || 0`is_free_in`e) =
+ bind_tail env' (Bind t' x tx e) | t==t' && (t==Lambda || 0`isFreeIn`e) =
[DocSpace,DocAssoc x' (go 0 env' tx)] + bind_tail ((x',tx):env') e
where x' = fresh (map fst env') x
bind_tail env' x = [bind_sep t,DocSpace,go 0 env' x]
- go d env (Cons a) = showA d a
- where showA _ (Ap h xs) =
+ go d env (Cons a) = showA d env a
+ where showA _ envA (Ap h xs) =
let ni = case h of
- Sym i -> DocVarName $ case drop i env of
+ Sym i -> DocVarName $ case drop i envA of
(h',_):_ -> h'
_ -> "#"+fromString (show i)
- Mu _ _ a' -> DocMu (showA 0 a')
+ Mu envD _ a' -> DocMu (showA 0 (map (\(x,tx,_) -> (x,tx)) envD + envA) a')
Axiom _ ax -> DocText (fromString $ show ax)
lvl = if empty xs then 1000 else 1
- in par lvl d $ DocSeq $ intercalate [DocSpace] $ map pure (ni:map (go 2 env) xs)
+ in par lvl d $ DocSeq $ intercalate [DocSpace] $ map pure (ni:map (go 2 envA) xs)
toPat d env x
| (pats,(_,k)):_ <- findPattern dir x =
@@ 468,16 548,18 @@ showNode' dir = go 0
fix (\kj -> \case
(Cons (Ap h t@(_:_)),_:env0)
| Cons (Ap (Sym 0) []) <- last t
- , not (is_free_in 0 (Cons (Ap h (init t))))
- -> kj (inc_depth (-1) (Cons (Ap h (init t))),env0)
- (Cons (Ap (Sym j') []),_:env0) | j'>0 -> kj (Cons (Ap (Sym (j'-1)) []),env0)
+ , not (0 `isFreeIn` Cons (Ap h (init t)))
+ -> kj (raiseRefs (-1) (Cons (Ap h (init t))),env0)
+ (Cons (Ap (Sym j') []),_:env0)
+ | j'>0
+ -> kj (Cons (Ap (Sym (j'-1)) []),env0)
e -> e) (hole,env')
in foldl' (\e (n,t) -> Bind Lambda n t e) hole' env''
| otherwise -> DocText "?"
| word <- k]
| otherwise = Nothing
-type_of :: (Show a,IsCapriconString str,MonadReader (Env str a) m) => Node str a -> m (Maybe (Node str a))
+type_of :: (Show a,IsCapriconString str,MonadReader [(str,Term str a)] m) => Term str a -> m (Maybe (Term str a))
type_of = yb maybeT . go
where go (Bind Lambda x tx e) = Bind Prod x tx <$> local ((x,tx):) (go e)
go (Bind Prod x tx e) = do
@@ 491,20 573,24 @@ type_of = yb maybeT . go
where go' (Ap (Sym i) subs) = do
e <- ask
case drop i e of
- (_,ti):_ -> rec_subst subs (inc_depth (i+1) ti)
+ (_,ti):_ -> rec_subst subs (raiseRefs (i+1) ti)
_ -> zero
go' (Ap (Mu env _ a') subs) = do
ta <- local (map (\(x,tx,_) -> (x,tx)) env +) (go' a')
preret <- maybeT $^ mu_type $ foldl' (\e (x,tx,_) -> Bind Prod x tx e) ta env
- rec_subst subs (subst (Cons a') preret)
+ rec_subst subs (subst (foldl' (\e (x,tx,_) -> Bind Lambda x tx e) (Cons a') env) preret)
go' (Ap (Axiom t _) subs) = rec_subst subs t
- rec_subst (y:t) (Bind Prod _ _ e) = rec_subst t (subst y e)
+ rec_subst (y:t) (Bind Prod _ tx e) = do
+ ty <- go y
+ (dx,_) <- return (unifyTerms ty tx)^.maybeT
+ guard (dx<=0)
+ rec_subst t (subst y e)
rec_subst [] x = return x
rec_subst _ _ = zero
-mu_type :: MonadReader (Env str a) m => Node str a -> m (Maybe (Node str a))
-mu_type (inc_depth 1 -> root_type) = yb maybeT $ go 0 root_type
+mu_type :: MonadReader [(str,Term str a)] m => Term str a -> m (Maybe (Term str a))
+mu_type (raiseRefs 1 -> root_type) = yb maybeT $ go 0 root_type
where
root_args = go' root_type
where go' (Bind Prod x tx e) = (x,tx):go' e
@@ 523,17 609,17 @@ mu_type (inc_depth 1 -> root_type) = yb maybeT $ go 0 root_type
go_col d xn = go_col' 0 (c'set zero)
where go_col' d' recs (Bind Prod x tx@(Cons (Ap (Sym i) subs)) e)
| constr_ind d d' i = do
- let tx' = bind Prod (adjust_telescope_depth second (+(d+d')) root_args)
- (adjust_depth (\i' -> if constr_ind d d' i' then (i'-d')+(nargs-d) else i'+nargs) tx)
- tIx = Cons $ Ap (Sym (i+1)) $ map (inc_depth 1) subs + [Cons (Ap (Sym 0) [])]
+ let tx' = bind Prod (telescope_adjustRefs second (+(d+d')) root_args)
+ (adjustRefs (\i' -> if constr_ind d d' i' then (i'-d')+(nargs-d) else i'+nargs) tx)
+ tIx = Cons $ Ap (Sym (i+1)) $ map (raiseRefs 1) subs + [Cons (Ap (Sym 0) [])]
e' <- local (((x,tx):) . (undefined:)) (go_col' (d'+2) (touch (1 :: Int) (map (+2) recs))
- (adjust_depth (\j -> if j==0 then j else j+1) e))
+ (adjustRefs (\j -> if j==0 then j else j+1) e))
return $ Bind Prod x tx' (Bind Prod x tIx e')
go_col' d' recs (Bind Prod x tx e) = Bind Prod x tx <$> local ((x,tx):) (go_col' (d'+1) (map (+1) recs) e)
go_col' d' recs (Cons (Ap (Sym i) xs))
| constr_ind d d' i = do
let args = reverse $ select (not . (`isKeyIn`recs)) [0..d'-1]
- lastE = bind Lambda (adjust_telescope_depth second (+(d+d')) root_args)
+ lastE = bind Lambda (telescope_adjustRefs second (+(d+d')) root_args)
(Cons (Ap (Sym (nargs-d-1))
[Cons (Ap (Sym (j'+nargs)) args')
| j <- args
@@ 541,9 627,8 @@ mu_type (inc_depth 1 -> root_type) = yb maybeT $ go 0 root_type
| otherwise = (j,[])
]))
return $ Cons (Ap (Sym i) $ xs+[lastE])
-
go_col' d' recs (Universe u) = do
- let tIH = bind Prod (adjust_telescope_depth second (+(d+d')) root_args) ihRoot
+ let tIH = bind Prod (telescope_adjustRefs second (+(d+d')) root_args) ihRoot
ihRoot = Cons (Ap (Sym (nargs-d-1)) [Cons $ Ap (Sym (j+nargs)) $
if j `isKeyIn` recs
then [Cons (Ap (Sym k) []) | k <- reverse [0..nargs-1]]
@@ 552,8 637,8 @@ mu_type (inc_depth 1 -> root_type) = yb maybeT $ go 0 root_type
return $ Bind Prod xn tIH (Universe (u+1))
go_col' _ _ _ = zero
-convertible :: Node str a -> Node str a -> Maybe (Int,Int)
-convertible = \x y -> map ((getMax<#>getMax) . fst) ((tell (Max 0,Max 0) >> go False x y)^..writerT)
+unifyTerms :: Term str a -> Term str a -> Maybe (Int,Int)
+unifyTerms = \x y -> map ((getMax<#>getMax) . fst) ((tell (Max 0,Max 0) >> go False x y)^..writerT)
where go inv (Bind b _ tx e) (Bind b' _ tx' e') = guard (b==b') >> go (not inv) tx tx' >> go inv e e'
go inv (Cons ax) (Cons ay) = go_a inv ax ay
go inv (Universe u) (Universe v) | u>v = tellInv inv (Max (u-v),zero)
M => +17 -17
@@ 32,37 32,37 @@ instance Serializable bytes str => Serializable bytes (AType str)
instance Format bytes str => Format bytes (Algebraic str)
instance Format bytes str => Format bytes (AType str)
fromNode :: (Show ax,IsCapriconString str,MonadReader ([Bool],Env str ax) m) => Node str ax -> m (Algebraic str)
fromNode (Bind Lambda x tx e) = do
fromTerm :: (Show ax,IsCapriconString str,MonadReader ([Bool],[(str,Term str ax)]) m) => Term str ax -> m (Algebraic str)
fromTerm (Bind Lambda x tx e) = do
let isT = isTypeType tx
e' <- local ((not isT:)<#>((x,tx):)) (fromNode e)
e' <- local ((not isT:)<#>((x,tx):)) (fromTerm e)
if isT then return e'
else AFun x <$> fromTypeNode tx <*> pure e'
fromNode (Cons a) = fromApplication a
fromNode _ = error "Cannot produce a type-term in a language without first-class types"
else AFun x <$> fromTypeTerm tx <*> pure e'
fromTerm (Cons a) = fromApplication a
fromTerm _ = error "Cannot produce a type-term in a language without first-class types"
fromApplication :: (Show ax,IsCapriconString str, MonadReader ([Bool],Env str ax) m) => Application str ax -> m (Algebraic str)
fromApplication :: (Show ax,IsCapriconString str, MonadReader ([Bool],[(str,Term str ax)]) m) => Application str ax -> m (Algebraic str)
fromApplication (Ap ah args) = do
(varKinds,env) <- ask
let concreteArgs = [arg | (arg,Just t) <- map (\x -> (x,(checkType x^..maybeT) env)) args
let concreteArgs = [arg | (arg,Just t) <- map (\x -> (x,type_of x env)) args
, not (isTypeType t)]
case ah of
Sym s -> foldl' (liftA2 AApply) (pure $ AVar $ sum [if isV then 1 else 0 | isV <- take s varKinds]) (map fromNode concreteArgs)
Mu _ _ a -> foldl' (liftA2 AApply) (fromApplication a) (map fromNode concreteArgs)
Sym s -> foldl' (liftA2 AApply) (pure $ AVar $ sum [if isV then 1 else 0 | isV <- take s varKinds]) (map fromTerm concreteArgs)
Mu _ _ a -> foldl' (liftA2 AApply) (fromApplication a) (map fromTerm concreteArgs)
Axiom _ _ -> undefined
fromTypeNode :: MonadReader ([Bool],Env str ax) m => Node str ax -> m (AType str)
fromTypeNode (Bind Prod x tx e) = do
fromTypeTerm :: MonadReader ([Bool],[(str,Term str ax)]) m => Term str ax -> m (AType str)
fromTypeTerm (Bind Prod x tx e) = do
let isT = isTypeType tx
e' <- local ((not isT:)<#>((x,tx):)) (fromTypeNode e)
e' <- local ((not isT:)<#>((x,tx):)) (fromTypeTerm e)
if isT then return AAny
else AArr <$> fromTypeNode tx <*> pure e'
fromTypeNode (Cons (Ap (Sym s) [])) = do
else AArr <$> fromTypeTerm tx <*> pure e'
fromTypeTerm (Cons (Ap (Sym s) [])) = do
(varKinds,_) <- ask
pure $ ATVar $ sum [if isV then 0 else 1 | isV <- take s varKinds]
fromTypeNode _ = pure AAny
fromTypeTerm _ = pure AAny
isTypeType :: Node str ax -> Bool
isTypeType :: Term str ax -> Bool
isTypeType (Universe _) = True
isTypeType (Bind Prod _ _ e) = isTypeType e
isTypeType _ = False
D curly-gateway/OPTIONS => curly-gateway/OPTIONS +0 -12
@@ 1,12 0,0 @@
--XRebindableSyntax
--XFlexibleInstances
--XMultiParamTypeClasses
--XFlexibleContexts
--XFunctionalDependencies
--XTypeOperators
--XTupleSections
--XImplicitParams
--XGeneralizedNewtypeDeriving
--XRankNTypes
--W
--O4
A curly-gui/ChangeLog.md => curly-gui/ChangeLog.md +5 -0
@@ 0,0 1,5 @@
+# Revision history for curly-gui
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
M curly/ChangeLog.md => curly/ChangeLog.md +17 -3
@@ 1,5 1,19 @@
-# Revision history for curly
+Revision history for curly
+===============
-## 0.1.0.0 -- YYYY-mm-dd
+### release-curly-0.59.5 / package-curly-0.59.5
-* First version. Released on an unsuspecting world.
+ - Integrate the 'curly-gui' and 'definitive-graphics' packages from old projects
+ - Update the repository URLs in the Curly documentation; update the install script to allow installing Bash completions in a standard location
+ - Start defining two new builtins, 'showExpr' and 'showSyntax', to help when debugging the behaviour of macros
+
+### release-curly-0.59.4.5 / package-curly-0.59.4.5
+
+ - Change the default Curly locations to follow the XDG specification when possible
+ - Correct a small parser bug that caused some interactive commands to need two newlines instead of one
+ - Integrate the 'bashcomps.shl' library into the Curly package, so that unprivileged users can still benefit from great completions
+
+### release-curly-0.59.4.4 / release-curly-0.59.4.3 / package-curly-0.59.4.3
+
+ - Change the default Curly locations to follow the XDG specification when possible
+ - Correct a small parser bug that caused some interactive commands to need two newlines instead of one
M curly/data/bash/completions/curly.arg.shf => curly/data/bash/completions/curly.arg.shf +1 -1
@@ 174,7 174,7 @@ function C.curly.arg() {
C.alt C.rawWordOf "${#compFlags[@]}" "${compFlags[@]}" "$@"
fi
C.alt C.curly.flags flag 6 -h --help -v --version -i --interactive "$@"
- C.alt C.curly.flags opt 4 -l --list-instances -s --serve-instance "$@"
+ C.alt C.curly.flags flag 4 -l --list-instances -s --serve-instance "$@"
C.alt C.curly.flags opt 2 -r --run C.curly.run_arg "$@"
C.alt C.curly.flags opt 2 -M --mount C.curly.input "$@"
C.alt C.curly.flags opt 2 -t --translate C.curly.translate "$@"
M curly/data/emacs/curly-utils.el => curly/data/emacs/curly-utils.el +27 -0
@@ 64,6 64,33 @@
) args ""))
(_ args)))
+(princ
+ (curly-lambda-match
+ ((:many . e)
+ (concat "\\(?:" (apply 'curly-re-construct e) "\\)*"))
+ ((:optional . e)
+ (concat "\\(?:" (apply 'curly-re-construct e) "\\)?"))
+ ((:sep-by sep . e)
+ (concat (apply 'curly-re-construct e)
+ "\\(?:" (curly-re-construct sep) (apply 'curly-re-construct e) "\\)*"))
+ ((:or . e)
+ (concat "\\(?:" (mapconcat 'curly-re-construct e "\\|") "\\)"))
+ ((:capture . e)
+ (concat "\\(" (apply 'curly-re-construct e) "\\)"))
+ ((:partial e) (curly-re-construct e))
+ ((:partial e . es)
+ (concat (curly-re-construct e) (curly-re-construct `(:optional (:partial . ,es)))))
+ (:bol "^")
+ (:eol "$")
+ (:bow "\\<")
+ (:eow "\\>")
+ (:word "\\<\\sw*[^[:blank:]:=]")
+ (:spc "\\s-*")
+ (:nbsp "\\s-+")
+ ((@ l (_ . _)) (apply 'curly-re-construct l))
+ (x x)
+ ))
+
(defmacro curly-regex (&rest args) (curly-re-construct args))
(defmacro curly-keyword (re &rest args)
"" (declare (indent 1))
M curly/data/install.sh => curly/data/install.sh +84 -0
@@ 3,6 3,10 @@ get_data() {
printf "Installing goody %s at location %s\n" "$2" "$1"
curly --goody="$2" > "$1"
}
+trace() {
+ printf "Running: %s\n" "$*" >&2
+ "$@"
+}
case "$1" in
emacs)
ver=`curly -v | cut -d' ' -f3`
@@ 35,4 39,84 @@ EOF
get_data "$root/completions/curly.script.shf" bash/completions/curly.script.shf
get_data "$root/completions/curly.sh" bash/completions/curly.sh
;;
+
+ handlers)
+ root="${XDG_DATA_HOME:-$HOME/.local/share}"
+ mkdir -p "$root"
+
+ echo "Installing desktop file at $root/applications/curly-uri.desktop" >&2
+ cat > "$root/applications/curly-uri.desktop" <<EOF
+[Desktop Entry]
+Version=1.0
+Type=Application
+Exec=$root/curly/handlers/curly-uri %u
+Name=Install Curly Program
+Comment=Installs a program from a Curly URI
+MimeType=x-scheme-handler/curly
+EOF
+
+ echo "Updating desktop database" >&2
+ update-desktop-database "$root/applications"
+
+ echo "Installing handler $root/curly/handlers/curly-uri" >&2
+ mkdir -p "$root/curly/handlers"
+
+ cat > "$root/curly/handlers/curly-uri" <<EOF
+#!/bin/sh
+curly --goody install.sh | sh -s - "\$@"
+EOF
+ chmod +x "$root/curly/handlers/curly-uri"
+
+ ;;
+
+ curly:*)
+ uri="${1#curly:}"
+ lib="${uri#//*/}"
+ host="${uri%$lib}"
+ lib="${lib%%/*}"
+ prog="${uri#$host$lib}"
+ prog="${prog#/}"
+ contains() {
+ case "$1" in
+ *"$2"*) return 0;;
+ *) return 1;;
+ esac
+ }
+ while contains "$prog" /; do
+ prog="${prog%%/*}.${prog#*/}"
+ done
+ case "$host" in
+ //*/)
+ host="${host#//}"; host="${host%/}"
+ if [ -z "`curly %"key meta $host"`" ]; then
+ curly %"key import $host $host" 2>/dev/null
+ fi
+ cmd="curly --mount p=package:$host:$lib %'run p.$prog'"
+ ;;
+ *)
+ cmd="curly --mount p=library:$lib %'run p.$prog'"
+ ;;
+ esac
+ if [ -t 1 ]; then
+ eval "$cmd"
+ else
+ cache="${XDG_CACHE_HOME:-$HOME/.cache}/curly/logs"
+ mkdir -p "$cache"
+ ts=`date +%s,%F,%T`
+ (
+ exec 2>&1
+ cat > "$cache/cmd-$ts.log.html" <<EOF
+<!DOCTYPE html>
+<html>
+ <head></head>
+ <body>
+ <pre style="background:black; color:white;"><span style="font-weight: bold">\$ $cmd</span>
+`eval "$cmd" 2>&1`</pre>
+ </body>
+</html>
+EOF
+ )
+ xdg-open "$cache/cmd-$ts.log.html"
+ fi
+ ;;
esac
M curly/doc/curly-language.md => curly/doc/curly-language.md +62 -1
@@ 17,7 17,7 @@ with all occurrences of x replaced by X".
Here are a few functions to help you get a feel of the language : `{x:
x}`{.curly}, the identity function; `{x _: x}`{.curly}, the constant function; `{f x
-y: f y x}`{.curly}, a function to flip its first arguments parameters.
+y: f y x}`{.curly}, a function to flip its first arguments' parameters.
Functions and operators
---------------------
@@ 233,3 233,64 @@ locally, or imported from another module).
If a leaf symbol has a local name, then the local symbol of that name
is exported instead of the leaf's name.
+### Definining system-specific values
+
+Sometimes, in the interest of efficiency or portability, it can be
+useful to have a symbol represent different implementations of a
+function on different systems. To define such symbols, Curly provides
+the `multi` pragma, with the following syntax :
+
+*Usage*: `multi SYMBOL = DEFAULT_SYMBOL [, SYSTEM_NAME SYSTEM_SYMBOL]...`
+
+This pragma define the multi-system symbol `SYMBOL`, with a system-specific
+implementation for each `SYSTEM_NAME`, and a fallback implementation
+defined in `DEFAULT_SYMBOL`.
+
+#### Example: packaging an external C library
+
+_Warning_: this is still a thought experiment. The Curly FFI is not yet
+capable of integrating with C, although it will be very soon.
+
+Imagine you have a C library called libX. You have the source for this
+library, and maybe a C cross-compiling toolchain for several
+systems. Using all this, you manage to compile libX into three dynamic
+libraries, that each run on a different ABI and maybe a different
+architecture. Let's call these `libX_arm-linux.so`,
+`libX_x86-linux.so`, and `libX_x86_64-linux.so`.
+
+You can now use Curly to create a library of bindings to libX, in a
+portable way. First, mount each .so to a point in context, using the
+"external" input source, along with a `libX.cy` source file :
+
+ #!/usr/bin/env curly
+ # A simple context file for libX
+ mount C libX arm = external libX_arm-linux.so
+ mount C libX x86 = external libX_x86-linux.so
+ mount C libX x86-64 = external libX_x86_64-linux.so
+
+ mount libX = source libX.cy
+
+That `libX.cy` file can now define a multi-symbol for each function of
+the libX library, handling each system accordingly :
+
+~~~~~~{.curly}
+module libX: Bindings to a library
+
+# Since each library exports the same symbols, we have to rename them during import
+import C.libX{
+ arm{f(arm'f) ...}
+ x86{f(x86'f) ...}
+ x86-64{f(x64'f) ...}
+ }
+
+let defaultImpl = undefined
+multi f = defaultImpl, linux-x86 x86'f, linux-arm arm'f, linux-x86-64 x64'f
+....
+
+export f ...
+~~~~~~~~~~
+
+You can now import the `libX` module anywhere, and use its functions
+on any of the three handled systems. The C binaries are no longer
+needed once `libX` has been compiled.
+
M curly/doc/downloads.md => curly/doc/downloads.md +2 -2
@@ 27,6 27,6 @@ the heights of getting to compile this fine compiler, by running the
following commands :
~~~{.terminal}
-git clone http://git.curly-lang.org/marc/curly
-cd curly && stack build
+git clone https://github.com/lih/BHR.git
+cd BHR && stack build curly
~~~~
M curly/doc/links.mdi => curly/doc/links.mdi +2 -3
@@ 1,6 1,5 @@
-
[curly-install-script]: install-curly.sh
-[curly-source]: https://git.curly-lang.org/marc/stack-libs/src/master/curly
+[curly-source]: https://github.com/lih/BHR/src/master/curly
[curly-package]: pkg/curly.tar.xz
[curly-linux-x86-64]: pkg/curly.tar.xz
-[curly-complaints]: http://git.curly-lang.org/marc/curly/issues
+[curly-complaints]: http://github.com/lih/BHR/issues
M curly/src/Curly/Session/Commands/Context.hs => curly/src/Curly/Session/Commands/Context.hs +3 -1
@@ 37,7 37,9 @@ metaDoc = [q_string|
|]
metaCmd = withDoc metaDoc $ fill False $ withMountain $ do
path <- many' (nbhspace >> dirArg)
- let mod = ?mountain >>= \fl -> mapF (\m -> ModDir (m^.ascList)) (Join (fl^.flLibrary.metadata.iso (\(Metadata m) -> m) Metadata))
+ let mod = ?mountain >>= \fl -> mapF (\m -> ModDir (m^.ascList))
+ (Join (insert "library-id" (Pure (show (fl^.flID)))
+ $ (fl^.flLibrary.metadata.iso (\(Metadata m) -> m) Metadata)))
serveStrLn $ maybe "" showMetaDir (mod^?atMs path)
reloadDoc = [q_string|
A definitive-graphics/ChangeLog.md => definitive-graphics/ChangeLog.md +5 -0
@@ 0,0 1,5 @@
+# Revision history for definitive-graphics
+
+## 2.2.0.1 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
D definitive-graphics/LICENSE => definitive-graphics/LICENSE +0 -674
@@ 1,674 0,0 @@
- GNU GENERAL PUBLIC LICENSE
- Version 3, 29 June 2007
-
- Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
- Preamble
-
- The GNU General Public License is a free, copyleft license for
-software and other kinds of works.
-
- The licenses for most software and other practical works are designed
-to take away your freedom to share and change the works. By contrast,
-the GNU General Public License is intended to guarantee your freedom to
-share and change all versions of a program--to make sure it remains free
-software for all its users. We, the Free Software Foundation, use the
-GNU General Public License for most of our software; it applies also to
-any other work released this way by its authors. You can apply it to
-your programs, too.
-
- When we speak of free software, we are referring to freedom, not
-price. Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-them if you wish), that you receive source code or can get it if you
-want it, that you can change the software or use pieces of it in new
-free programs, and that you know you can do these things.
-
- To protect your rights, we need to prevent others from denying you
-these rights or asking you to surrender the rights. Therefore, you have
-certain responsibilities if you distribute copies of the software, or if
-you modify it: responsibilities to respect the freedom of others.
-
- For example, if you distribute copies of such a program, whether
-gratis or for a fee, you must pass on to the recipients the same
-freedoms that you received. You must make sure that they, too, receive
-or can get the source code. And you must show them these terms so they
-know their rights.
-
- Developers that use the GNU GPL protect your rights with two steps:
-(1) assert copyright on the software, and (2) offer you this License
-giving you legal permission to copy, distribute and/or modify it.
-
- For the developers' and authors' protection, the GPL clearly explains
-that there is no warranty for this free software. For both users' and
-authors' sake, the GPL requires that modified versions be marked as
-changed, so that their problems will not be attributed erroneously to
-authors of previous versions.
-
- Some devices are designed to deny users access to install or run
-modified versions of the software inside them, although the manufacturer
-can do so. This is fundamentally incompatible with the aim of
-protecting users' freedom to change the software. The systematic
-pattern of such abuse occurs in the area of products for individuals to
-use, which is precisely where it is most unacceptable. Therefore, we
-have designed this version of the GPL to prohibit the practice for those
-products. If such problems arise substantially in other domains, we
-stand ready to extend this provision to those domains in future versions
-of the GPL, as needed to protect the freedom of users.
-
- Finally, every program is threatened constantly by software patents.
-States should not allow patents to restrict development and use of
-software on general-purpose computers, but in those that do, we wish to
-avoid the special danger that patents applied to a free program could
-make it effectively proprietary. To prevent this, the GPL assures that
-patents cannot be used to render the program non-free.
-
- The precise terms and conditions for copying, distribution and
-modification follow.
-
- TERMS AND CONDITIONS
-
- 0. Definitions.
-
- "This License" refers to version 3 of the GNU General Public License.
-
- "Copyright" also means copyright-like laws that apply to other kinds of
-works, such as semiconductor masks.
-
- "The Program" refers to any copyrightable work licensed under this
-License. Each licensee is addressed as "you". "Licensees" and
-"recipients" may be individuals or organizations.
-
- To "modify" a work means to copy from or adapt all or part of the work
-in a fashion requiring copyright permission, other than the making of an
-exact copy. The resulting work is called a "modified version" of the
-earlier work or a work "based on" the earlier work.
-
- A "covered work" means either the unmodified Program or a work based
-on the Program.
-
- To "propagate" a work means to do anything with it that, without
-permission, would make you directly or secondarily liable for
-infringement under applicable copyright law, except executing it on a
-computer or modifying a private copy. Propagation includes copying,
-distribution (with or without modification), making available to the
-public, and in some countries other activities as well.
-
- To "convey" a work means any kind of propagation that enables other
-parties to make or receive copies. Mere interaction with a user through
-a computer network, with no transfer of a copy, is not conveying.
-
- An interactive user interface displays "Appropriate Legal Notices"
-to the extent that it includes a convenient and prominently visible
-feature that (1) displays an appropriate copyright notice, and (2)
-tells the user that there is no warranty for the work (except to the
-extent that warranties are provided), that licensees may convey the
-work under this License, and how to view a copy of this License. If
-the interface presents a list of user commands or options, such as a
-menu, a prominent item in the list meets this criterion.
-
- 1. Source Code.
-
- The "source code" for a work means the preferred form of the work
-for making modifications to it. "Object code" means any non-source
-form of a work.
-
- A "Standard Interface" means an interface that either is an official
-standard defined by a recognized standards body, or, in the case of
-interfaces specified for a particular programming language, one that
-is widely used among developers working in that language.
-
- The "System Libraries" of an executable work include anything, other
-than the work as a whole, that (a) is included in the normal form of
-packaging a Major Component, but which is not part of that Major
-Component, and (b) serves only to enable use of the work with that
-Major Component, or to implement a Standard Interface for which an
-implementation is available to the public in source code form. A
-"Major Component", in this context, means a major essential component
-(kernel, window system, and so on) of the specific operating system
-(if any) on which the executable work runs, or a compiler used to
-produce the work, or an object code interpreter used to run it.
-
- The "Corresponding Source" for a work in object code form means all
-the source code needed to generate, install, and (for an executable
-work) run the object code and to modify the work, including scripts to
-control those activities. However, it does not include the work's
-System Libraries, or general-purpose tools or generally available free
-programs which are used unmodified in performing those activities but
-which are not part of the work. For example, Corresponding Source
-includes interface definition files associated with source files for
-the work, and the source code for shared libraries and dynamically
-linked subprograms that the work is specifically designed to require,
-such as by intimate data communication or control flow between those
-subprograms and other parts of the work.
-
- The Corresponding Source need not include anything that users
-can regenerate automatically from other parts of the Corresponding
-Source.
-
- The Corresponding Source for a work in source code form is that
-same work.
-
- 2. Basic Permissions.
-
- All rights granted under this License are granted for the term of
-copyright on the Program, and are irrevocable provided the stated
-conditions are met. This License explicitly affirms your unlimited
-permission to run the unmodified Program. The output from running a
-covered work is covered by this License only if the output, given its
-content, constitutes a covered work. This License acknowledges your
-rights of fair use or other equivalent, as provided by copyright law.
-
- You may make, run and propagate covered works that you do not
-convey, without conditions so long as your license otherwise remains
-in force. You may convey covered works to others for the sole purpose
-of having them make modifications exclusively for you, or provide you
-with facilities for running those works, provided that you comply with
-the terms of this License in conveying all material for which you do
-not control copyright. Those thus making or running the covered works
-for you must do so exclusively on your behalf, under your direction
-and control, on terms that prohibit them from making any copies of
-your copyrighted material outside their relationship with you.
-
- Conveying under any other circumstances is permitted solely under
-the conditions stated below. Sublicensing is not allowed; section 10
-makes it unnecessary.
-
- 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
-
- No covered work shall be deemed part of an effective technological
-measure under any applicable law fulfilling obligations under article
-11 of the WIPO copyright treaty adopted on 20 December 1996, or
-similar laws prohibiting or restricting circumvention of such
-measures.
-
- When you convey a covered work, you waive any legal power to forbid
-circumvention of technological measures to the extent such circumvention
-is effected by exercising rights under this License with respect to
-the covered work, and you disclaim any intention to limit operation or
-modification of the work as a means of enforcing, against the work's
-users, your or third parties' legal rights to forbid circumvention of
-technological measures.
-
- 4. Conveying Verbatim Copies.
-
- You may convey verbatim copies of the Program's source code as you
-receive it, in any medium, provided that you conspicuously and
-appropriately publish on each copy an appropriate copyright notice;
-keep intact all notices stating that this License and any
-non-permissive terms added in accord with section 7 apply to the code;
-keep intact all notices of the absence of any warranty; and give all
-recipients a copy of this License along with the Program.
-
- You may charge any price or no price for each copy that you convey,
-and you may offer support or warranty protection for a fee.
-
- 5. Conveying Modified Source Versions.
-
- You may convey a work based on the Program, or the modifications to
-produce it from the Program, in the form of source code under the
-terms of section 4, provided that you also meet all of these conditions:
-
- a) The work must carry prominent notices stating that you modified
- it, and giving a relevant date.
-
- b) The work must carry prominent notices stating that it is
- released under this License and any conditions added under section
- 7. This requirement modifies the requirement in section 4 to
- "keep intact all notices".
-
- c) You must license the entire work, as a whole, under this
- License to anyone who comes into possession of a copy. This
- License will therefore apply, along with any applicable section 7
- additional terms, to the whole of the work, and all its parts,
- regardless of how they are packaged. This License gives no
- permission to license the work in any other way, but it does not
- invalidate such permission if you have separately received it.
-
- d) If the work has interactive user interfaces, each must display
- Appropriate Legal Notices; however, if the Program has interactive
- interfaces that do not display Appropriate Legal Notices, your
- work need not make them do so.
-
- A compilation of a covered work with other separate and independent
-works, which are not by their nature extensions of the covered work,
-and which are not combined with it such as to form a larger program,
-in or on a volume of a storage or distribution medium, is called an
-"aggregate" if the compilation and its resulting copyright are not
-used to limit the access or legal rights of the compilation's users
-beyond what the individual works permit. Inclusion of a covered work
-in an aggregate does not cause this License to apply to the other
-parts of the aggregate.
-
- 6. Conveying Non-Source Forms.
-
- You may convey a covered work in object code form under the terms
-of sections 4 and 5, provided that you also convey the
-machine-readable Corresponding Source under the terms of this License,
-in one of these ways:
-
- a) Convey the object code in, or embodied in, a physical product
- (including a physical distribution medium), accompanied by the
- Corresponding Source fixed on a durable physical medium
- customarily used for software interchange.
-
- b) Convey the object code in, or embodied in, a physical product
- (including a physical distribution medium), accompanied by a
- written offer, valid for at least three years and valid for as
- long as you offer spare parts or customer support for that product
- model, to give anyone who possesses the object code either (1) a
- copy of the Corresponding Source for all the software in the
- product that is covered by this License, on a durable physical
- medium customarily used for software interchange, for a price no
- more than your reasonable cost of physically performing this
- conveying of source, or (2) access to copy the
- Corresponding Source from a network server at no charge.
-
- c) Convey individual copies of the object code with a copy of the
- written offer to provide the Corresponding Source. This
- alternative is allowed only occasionally and noncommercially, and
- only if you received the object code with such an offer, in accord
- with subsection 6b.
-
- d) Convey the object code by offering access from a designated
- place (gratis or for a charge), and offer equivalent access to the
- Corresponding Source in the same way through the same place at no
- further charge. You need not require recipients to copy the
- Corresponding Source along with the object code. If the place to
- copy the object code is a network server, the Corresponding Source
- may be on a different server (operated by you or a third party)
- that supports equivalent copying facilities, provided you maintain
- clear directions next to the object code saying where to find the
- Corresponding Source. Regardless of what server hosts the
- Corresponding Source, you remain obligated to ensure that it is
- available for as long as needed to satisfy these requirements.
-
- e) Convey the object code using peer-to-peer transmission, provided
- you inform other peers where the object code and Corresponding
- Source of the work are being offered to the general public at no
- charge under subsection 6d.
-
- A separable portion of the object code, whose source code is excluded
-from the Corresponding Source as a System Library, need not be
-included in conveying the object code work.
-
- A "User Product" is either (1) a "consumer product", which means any
-tangible personal property which is normally used for personal, family,
-or household purposes, or (2) anything designed or sold for incorporation
-into a dwelling. In determining whether a product is a consumer product,
-doubtful cases shall be resolved in favor of coverage. For a particular
-product received by a particular user, "normally used" refers to a
-typical or common use of that class of product, regardless of the status
-of the particular user or of the way in which the particular user
-actually uses, or expects or is expected to use, the product. A product
-is a consumer product regardless of whether the product has substantial
-commercial, industrial or non-consumer uses, unless such uses represent
-the only significant mode of use of the product.
-
- "Installation Information" for a User Product means any methods,
-procedures, authorization keys, or other information required to install
-and execute modified versions of a covered work in that User Product from
-a modified version of its Corresponding Source. The information must
-suffice to ensure that the continued functioning of the modified object
-code is in no case prevented or interfered with solely because
-modification has been made.
-
- If you convey an object code work under this section in, or with, or
-specifically for use in, a User Product, and the conveying occurs as
-part of a transaction in which the right of possession and use of the
-User Product is transferred to the recipient in perpetuity or for a
-fixed term (regardless of how the transaction is characterized), the
-Corresponding Source conveyed under this section must be accompanied
-by the Installation Information. But this requirement does not apply
-if neither you nor any third party retains the ability to install
-modified object code on the User Product (for example, the work has
-been installed in ROM).
-
- The requirement to provide Installation Information does not include a
-requirement to continue to provide support service, warranty, or updates
-for a work that has been modified or installed by the recipient, or for
-the User Product in which it has been modified or installed. Access to a
-network may be denied when the modification itself materially and
-adversely affects the operation of the network or violates the rules and
-protocols for communication across the network.
-
- Corresponding Source conveyed, and Installation Information provided,
-in accord with this section must be in a format that is publicly
-documented (and with an implementation available to the public in
-source code form), and must require no special password or key for
-unpacking, reading or copying.
-
- 7. Additional Terms.
-
- "Additional permissions" are terms that supplement the terms of this
-License by making exceptions from one or more of its conditions.
-Additional permissions that are applicable to the entire Program shall
-be treated as though they were included in this License, to the extent
-that they are valid under applicable law. If additional permissions
-apply only to part of the Program, that part may be used separately
-under those permissions, but the entire Program remains governed by
-this License without regard to the additional permissions.
-
- When you convey a copy of a covered work, you may at your option
-remove any additional permissions from that copy, or from any part of
-it. (Additional permissions may be written to require their own
-removal in certain cases when you modify the work.) You may place
-additional permissions on material, added by you to a covered work,
-for which you have or can give appropriate copyright permission.
-
- Notwithstanding any other provision of this License, for material you
-add to a covered work, you may (if authorized by the copyright holders of
-that material) supplement the terms of this License with terms:
-
- a) Disclaiming warranty or limiting liability differently from the
- terms of sections 15 and 16 of this License; or
-
- b) Requiring preservation of specified reasonable legal notices or
- author attributions in that material or in the Appropriate Legal
- Notices displayed by works containing it; or
-
- c) Prohibiting misrepresentation of the origin of that material, or
- requiring that modified versions of such material be marked in
- reasonable ways as different from the original version; or
-
- d) Limiting the use for publicity purposes of names of licensors or
- authors of the material; or
-
- e) Declining to grant rights under trademark law for use of some
- trade names, trademarks, or service marks; or
-
- f) Requiring indemnification of licensors and authors of that
- material by anyone who conveys the material (or modified versions of
- it) with contractual assumptions of liability to the recipient, for
- any liability that these contractual assumptions directly impose on
- those licensors and authors.
-
- All other non-permissive additional terms are considered "further
-restrictions" within the meaning of section 10. If the Program as you
-received it, or any part of it, contains a notice stating that it is
-governed by this License along with a term that is a further
-restriction, you may remove that term. If a license document contains
-a further restriction but permits relicensing or conveying under this
-License, you may add to a covered work material governed by the terms
-of that license document, provided that the further restriction does
-not survive such relicensing or conveying.
-
- If you add terms to a covered work in accord with this section, you
-must place, in the relevant source files, a statement of the
-additional terms that apply to those files, or a notice indicating
-where to find the applicable terms.
-
- Additional terms, permissive or non-permissive, may be stated in the
-form of a separately written license, or stated as exceptions;
-the above requirements apply either way.
-
- 8. Termination.
-
- You may not propagate or modify a covered work except as expressly
-provided under this License. Any attempt otherwise to propagate or
-modify it is void, and will automatically terminate your rights under
-this License (including any patent licenses granted under the third
-paragraph of section 11).
-
- However, if you cease all violation of this License, then your
-license from a particular copyright holder is reinstated (a)
-provisionally, unless and until the copyright holder explicitly and
-finally terminates your license, and (b) permanently, if the copyright
-holder fails to notify you of the violation by some reasonable means
-prior to 60 days after the cessation.
-
- Moreover, your license from a particular copyright holder is
-reinstated permanently if the copyright holder notifies you of the
-violation by some reasonable means, this is the first time you have
-received notice of violation of this License (for any work) from that
-copyright holder, and you cure the violation prior to 30 days after
-your receipt of the notice.
-
- Termination of your rights under this section does not terminate the
-licenses of parties who have received copies or rights from you under
-this License. If your rights have been terminated and not permanently
-reinstated, you do not qualify to receive new licenses for the same
-material under section 10.
-
- 9. Acceptance Not Required for Having Copies.
-
- You are not required to accept this License in order to receive or
-run a copy of the Program. Ancillary propagation of a covered work
-occurring solely as a consequence of using peer-to-peer transmission
-to receive a copy likewise does not require acceptance. However,
-nothing other than this License grants you permission to propagate or
-modify any covered work. These actions infringe copyright if you do
-not accept this License. Therefore, by modifying or propagating a
-covered work, you indicate your acceptance of this License to do so.
-
- 10. Automatic Licensing of Downstream Recipients.
-
- Each time you convey a covered work, the recipient automatically
-receives a license from the original licensors, to run, modify and
-propagate that work, subject to this License. You are not responsible
-for enforcing compliance by third parties with this License.
-
- An "entity transaction" is a transaction transferring control of an
-organization, or substantially all assets of one, or subdividing an
-organization, or merging organizations. If propagation of a covered
-work results from an entity transaction, each party to that
-transaction who receives a copy of the work also receives whatever
-licenses to the work the party's predecessor in interest had or could
-give under the previous paragraph, plus a right to possession of the
-Corresponding Source of the work from the predecessor in interest, if
-the predecessor has it or can get it with reasonable efforts.
-
- You may not impose any further restrictions on the exercise of the
-rights granted or affirmed under this License. For example, you may
-not impose a license fee, royalty, or other charge for exercise of
-rights granted under this License, and you may not initiate litigation
-(including a cross-claim or counterclaim in a lawsuit) alleging that
-any patent claim is infringed by making, using, selling, offering for
-sale, or importing the Program or any portion of it.
-
- 11. Patents.
-
- A "contributor" is a copyright holder who authorizes use under this
-License of the Program or a work on which the Program is based. The
-work thus licensed is called the contributor's "contributor version".
-
- A contributor's "essential patent claims" are all patent claims
-owned or controlled by the contributor, whether already acquired or
-hereafter acquired, that would be infringed by some manner, permitted
-by this License, of making, using, or selling its contributor version,
-but do not include claims that would be infringed only as a
-consequence of further modification of the contributor version. For
-purposes of this definition, "control" includes the right to grant
-patent sublicenses in a manner consistent with the requirements of
-this License.
-
- Each contributor grants you a non-exclusive, worldwide, royalty-free
-patent license under the contributor's essential patent claims, to
-make, use, sell, offer for sale, import and otherwise run, modify and
-propagate the contents of its contributor version.
-
- In the following three paragraphs, a "patent license" is any express
-agreement or commitment, however denominated, not to enforce a patent
-(such as an express permission to practice a patent or covenant not to
-sue for patent infringement). To "grant" such a patent license to a
-party means to make such an agreement or commitment not to enforce a
-patent against the party.
-
- If you convey a covered work, knowingly relying on a patent license,
-and the Corresponding Source of the work is not available for anyone
-to copy, free of charge and under the terms of this License, through a
-publicly available network server or other readily accessible means,
-then you must either (1) cause the Corresponding Source to be so
-available, or (2) arrange to deprive yourself of the benefit of the
-patent license for this particular work, or (3) arrange, in a manner
-consistent with the requirements of this License, to extend the patent
-license to downstream recipients. "Knowingly relying" means you have
-actual knowledge that, but for the patent license, your conveying the
-covered work in a country, or your recipient's use of the covered work
-in a country, would infringe one or more identifiable patents in that
-country that you have reason to believe are valid.
-
- If, pursuant to or in connection with a single transaction or
-arrangement, you convey, or propagate by procuring conveyance of, a
-covered work, and grant a patent license to some of the parties
-receiving the covered work authorizing them to use, propagate, modify
-or convey a specific copy of the covered work, then the patent license
-you grant is automatically extended to all recipients of the covered
-work and works based on it.
-
- A patent license is "discriminatory" if it does not include within
-the scope of its coverage, prohibits the exercise of, or is
-conditioned on the non-exercise of one or more of the rights that are
-specifically granted under this License. You may not convey a covered
-work if you are a party to an arrangement with a third party that is
-in the business of distributing software, under which you make payment
-to the third party based on the extent of your activity of conveying
-the work, and under which the third party grants, to any of the
-parties who would receive the covered work from you, a discriminatory
-patent license (a) in connection with copies of the covered work
-conveyed by you (or copies made from those copies), or (b) primarily
-for and in connection with specific products or compilations that
-contain the covered work, unless you entered into that arrangement,
-or that patent license was granted, prior to 28 March 2007.
-
- Nothing in this License shall be construed as excluding or limiting
-any implied license or other defenses to infringement that may
-otherwise be available to you under applicable patent law.
-
- 12. No Surrender of Others' Freedom.
-
- If conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License. If you cannot convey a
-covered work so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you may
-not convey it at all. For example, if you agree to terms that obligate you
-to collect a royalty for further conveying from those to whom you convey
-the Program, the only way you could satisfy both those terms and this
-License would be to refrain entirely from conveying the Program.
-
- 13. Use with the GNU Affero General Public License.
-
- Notwithstanding any other provision of this License, you have
-permission to link or combine any covered work with a work licensed
-under version 3 of the GNU Affero General Public License into a single
-combined work, and to convey the resulting work. The terms of this
-License will continue to apply to the part which is the covered work,
-but the special requirements of the GNU Affero General Public License,
-section 13, concerning interaction through a network will apply to the
-combination as such.
-
- 14. Revised Versions of this License.
-
- The Free Software Foundation may publish revised and/or new versions of
-the GNU General Public License from time to time. Such new versions will
-be similar in spirit to the present version, but may differ in detail to
-address new problems or concerns.
-
- Each version is given a distinguishing version number. If the
-Program specifies that a certain numbered version of the GNU General
-Public License "or any later version" applies to it, you have the
-option of following the terms and conditions either of that numbered
-version or of any later version published by the Free Software
-Foundation. If the Program does not specify a version number of the
-GNU General Public License, you may choose any version ever published
-by the Free Software Foundation.
-
- If the Program specifies that a proxy can decide which future
-versions of the GNU General Public License can be used, that proxy's
-public statement of acceptance of a version permanently authorizes you
-to choose that version for the Program.
-
- Later license versions may give you additional or different
-permissions. However, no additional obligations are imposed on any
-author or copyright holder as a result of your choosing to follow a
-later version.
-
- 15. Disclaimer of Warranty.
-
- THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
-APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
-HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
-OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
-THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
-IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
-ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
-
- 16. Limitation of Liability.
-
- IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
-THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
-GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
-USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
-DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
-PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
-EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
-SUCH DAMAGES.
-
- 17. Interpretation of Sections 15 and 16.
-
- If the disclaimer of warranty and limitation of liability provided
-above cannot be given local legal effect according to their terms,
-reviewing courts shall apply local law that most closely approximates
-an absolute waiver of all civil liability in connection with the
-Program, unless a warranty or assumption of liability accompanies a
-copy of the Program in return for a fee.
-
- END OF TERMS AND CONDITIONS
-
- How to Apply These Terms to Your New Programs
-
- If you develop a new program, and you want it to be of the greatest
-possible use to the public, the best way to achieve this is to make it
-free software which everyone can redistribute and change under these terms.
-
- To do so, attach the following notices to the program. It is safest
-to attach them to the start of each source file to most effectively
-state the exclusion of warranty; and each file should have at least
-the "copyright" line and a pointer to where the full notice is found.
-
- <one line to give the program's name and a brief idea of what it does.>
- Copyright (C) <year> <name of author>
-
- This program is free software: you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-Also add information on how to contact you by electronic and paper mail.
-
- If the program does terminal interaction, make it output a short
-notice like this when it starts in an interactive mode:
-
- <program> Copyright (C) <year> <name of author>
- This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
- This is free software, and you are welcome to redistribute it
- under certain conditions; type `show c' for details.
-
-The hypothetical commands `show w' and `show c' should show the appropriate
-parts of the General Public License. Of course, your program's commands
-might be different; for a GUI interface, you would use an "about box".
-
- You should also get your employer (if you work as a programmer) or school,
-if any, to sign a "copyright disclaimer" for the program, if necessary.
-For more information on this, and how to apply and follow the GNU GPL, see
-<http://www.gnu.org/licenses/>.
-
- The GNU General Public License does not permit incorporating your program
-into proprietary programs. If your program is a subroutine library, you
-may consider it more useful to permit linking proprietary applications with
-the library. If this is what you want to do, use the GNU Lesser General
-Public License instead of this License. But first, please read
-<http://www.gnu.org/philosophy/why-not-lgpl.html>.
A definitive-graphics/LICENSE => definitive-graphics/LICENSE +1 -0
@@ 0,0 1,1 @@
+../LICENSE<
\ No newline at end of file
M definitive-graphics/source/Graphics/Widget/Traits.hs => definitive-graphics/source/Graphics/Widget/Traits.hs +6 -1
@@ 22,7 22,8 @@ module Graphics.Widget.Traits(
import Definitive
import Foreign.Ptr
-import Foreign.ForeignPtr
+import Foreign.ForeignPtr hiding (newForeignPtr)
+import Foreign.Concurrent
import IO.Time (Seconds)
import Graphics.GDK.KeyCodes
import IO.Dynamic
@@ 38,8 39,12 @@ data WProps a = WProps {
_wPropsValue :: a
}
nullWidgetPtr = thunk $^ do
+<<<<<<< HEAD
cb <- callback_p_ (const unit)
newForeignPtr cb nullPtr
+=======
+ newForeignPtr nullPtr unit
+>>>>>>> f978fa3cb9c33a7895a1410e14a86e07f5be518b
instance Functor WProps where map f (WProps h a) = WProps h (f a)
instance Unit WProps where pure x = WProps nullWidgetPtr x
instance SemiApplicative WProps where WProps h f <*> WProps h' x = WProps (max h h') (f x)
M logos/doc/examples/demo => logos/doc/examples/demo +3 -3
@@ 45,7 45,7 @@
, green 0 0 0 point 0 0 1 point ]
components 'LINES mesh def
-'Uniform { dup "set-%s" format swap { {@ dup uniform @} 1 dupn defuniform , {@ @} swap def } def } def
+'Uniform { dup "set-%s" format swap { ,{ dup uniform } 1 dupn defuniform ,{ } swap def } def } def
'modelMat Uniform
'viewMat Uniform
@@ 64,7 64,7 @@
'ambiantLuminosity Uniform , 0.6 set-ambiantLuminosity
identity set-modelMat
-'=> { {@ 'modelMat uniform @} swap [ 2 shaft ] } def
+'=> { ,{ 'modelMat uniform } swap [ 2 shaft ] } def
'scene [
10 range {
@@ 106,7 106,7 @@ view-trans set-viewMat
"press UP" { 'view-zy-angle { dyz ** } modify set-camera refresh } bind-key
"press DOWN" { 'view-zy-angle { dzy ** } modify set-camera refresh } bind-key
"press KP_ADD" { 'view-scale { 1.1 ** } modify set-camera refresh } bind-key
-"press KP_SUBTRACT" { 'view-scale { {@ {@ 1.1 recip @} @} ** } modify set-camera refresh } bind-key
+"press KP_SUBTRACT" { 'view-scale { ,{ ,{ 1.1 recip } } ** } modify set-camera refresh } bind-key
"press ESC" { quit } bind-key
"press Q" { ctrl { quit } { } if } bind-key
M logos/exe/Logos.hs => logos/exe/Logos.hs +1 -1
@@ 430,7 430,7 @@ main = between (void GLFW.initialize) GLFW.terminate $ do
let go = while $ do
ws <- liftIO (readChan wordChan)
- (traverse_ (execSymbol runLogos (\_ -> unit)) <|> execProgram runLogos (\_ -> unit)) ws
+ (traverse_ (execSymbol runLogos (\_ -> unit) . atomClass) <|> execProgram runLogos (\_ -> unit)) ws
runDictState get >>= \d -> liftIO (writeIORef symList (keys d))
runExtraState $ getl running
M logos/logos.cabal => logos/logos.cabal +2 -1
@@ 19,11 19,12 @@ library
default-language: Haskell2010
executable logos
- build-depends: base >=4.9 && <4.10,capricon >=0.10 && <0.11,definitive-base >=2.6 && <2.7,definitive-parser >=3.1 && <3.2,GLFW >=0.5 && <0.6,hreadline >=0.2 && <0.3,JuicyPixels >=3.2 && <3.3,logos >=0.1 && <0.2,OpenGL >=3.0 && <3.1,StateVar >=1.1 && <1.2,vector >=0.12 && <0.13
+ build-depends: base >=4.9 && <4.10,capricon >=0.10 && <0.14,definitive-base >=2.6 && <2.7,definitive-parser >=3.1 && <3.2,GLFW >=0.5 && <0.6,hreadline >=0.2 && <0.3,JuicyPixels >=3.2 && <3.3,logos >=0.1 && <0.2,OpenGL >=3.0 && <3.1,StateVar >=1.1 && <1.2,vector >=0.12 && <0.13
default-extensions: TypeSynonymInstances, NoMonomorphismRestriction, StandaloneDeriving, GeneralizedNewtypeDeriving, TypeOperators, RebindableSyntax, FlexibleInstances, FlexibleContexts, FunctionalDependencies, TupleSections, MultiParamTypeClasses, Rank2Types, AllowAmbiguousTypes, RoleAnnotations, ViewPatterns, LambdaCase
hs-source-dirs: exe
ghc-options: -threaded
main-is: Logos.hs
default-language: Haskell2010
+
M logos/src/Data/Font.hs => logos/src/Data/Font.hs +41 -13
@@ 62,10 62,25 @@ data RenderParams = RenderParams {
renderSizeAlignment :: Int, -- ^ The alignment required for the sizes of the returned buffer (OpenGL needs it to be a multiple of 4)
renderMode :: RenderMode
}
+<<<<<<< HEAD
data CellCoords = CellCoords {
cellX,cellY,
cellWidth,cellHeight,
cellCenterX,cellCenterY :: Int
+=======
+data CellMetrics = CellMetrics {
+ cellLeftWidth, cellRightWidth,
+ cellBottomHeight, cellTopHeight :: Int
+ }
+ deriving Show
+instance Semigroup CellMetrics where
+ CellMetrics lw rw bh th + CellMetrics lw' rw' bh' th' =
+ CellMetrics (lw+rw) (lw'+rw') (max bh bh') (max th th')
+data CellCoords = CellCoords {
+ cellX,cellY :: Int,
+ cellMetrics :: CellMetrics,
+ glyphMetrics :: CellMetrics
+>>>>>>> f978fa3cb9c33a7895a1410e14a86e07f5be518b
}
deriving Show
data StringImage = StringImage {
@@ 78,20 93,27 @@ data StringImage = StringImage {
defaultRenderParams :: RenderParams
defaultRenderParams = RenderParams 72 4 Grayscale
+getCharIndices fcp str = for str $ \c -> FT.ft_Get_Char_Index fcp (fromIntegral $ fromEnum c)
+getStringMetrics fcp slot indices = do
+ for indices $ \i -> do
+ throwOnError $ FT.ft_Load_Glyph fcp i FT.ft_LOAD_NO_BITMAP
+ -- putStrLn $ "Loading metrics for glyph "++show i
+ peek (FT.metrics slot)
+
+renditionSize :: Int -> [FT.FT_Glyph_Metrics] -> (Int,Int)
+renditionSize align metrics = (foldMap (fromIntegral . FT.horiAdvance) metrics & toPixels,
+ foldl1' max (map (fromIntegral . FT.height) metrics) & toPixels)
+ where toPixels x = let y = ((x+63)`div`64)+align-1 in y-(y`mod`align)
+
renderString :: Face -> RenderParams -> String -> IO StringImage
renderString fc (RenderParams sz align mode) str = withFacePtr fc $ \fcp -> do
slot <- peek (FT.glyph fcp)
throwOnError $ FT.ft_Set_Pixel_Sizes fcp (fromIntegral sz) (fromIntegral sz)
- indices <- for str $ \c -> FT.ft_Get_Char_Index fcp (fromIntegral $ fromEnum c)
- metrics <- for indices $ \i -> do
- throwOnError $ FT.ft_Load_Glyph fcp i FT.ft_LOAD_NO_BITMAP
- -- putStrLn $ "Loading metrics for glyph "++show i
- peek (FT.metrics slot)
- let (sizeX,sizeY) = (foldMap (fromIntegral . FT.horiAdvance) (debug metrics) & toPixels,
- foldl1' max (map (fromIntegral . FT.height) metrics) & toPixels) :: (Int,Int)
- toPixels x = let y = ((x+63)`div`64)+align-1 in y-(y`mod`align)
+ indices <- getCharIndices fcp str
+ metrics <- getStringMetrics fcp slot indices
+ let (sizeX,sizeY) = renditionSize align metrics
modeCode = case mode of
Grayscale -> FT.ft_RENDER_MODE_NORMAL
Monochromatic -> FT.ft_RENDER_MODE_MONO
@@ 112,15 134,21 @@ renderString fc (RenderParams sz align mode) str = withFacePtr fc $ \fcp -> do
start | incr > 0 = FTBMP.buffer bmp`plusPtr`((h-1)*incr)
| otherwise = FTBMP.buffer bmp
rowPtrs = iterate (`plusPtr`negate incr) start
- adv = fromIntegral (FT.horiAdvance m`div`64)
-- putStrLn $ "Copying rows of size "++show w++" from "++show start++" to "++show (pret`plusPtr`dx)++" (size "++show (sizeX-dx)++")"
for_ (take h rowPtrs `zip` iterate (`plusPtr`sizeX) (pret `plusPtr` dx)) $ \(rowsrc,rowdst) -> do
copyArray rowdst rowsrc w
-
- k (dx + adv) (insert c (CellCoords dx 0 adv h
- (fromIntegral (FT.horiBearingX m)`div`64 + w`div`2)
- (fromIntegral (FT.height m P.- FT.horiBearingY m)`div`64)) ret)
+ let adv = fromIntegral (FT.horiAdvance m`div`64)
+ bearX = fromIntegral (FT.horiBearingX m`div`64)
+ bearY = fromIntegral (FT.horiBearingX m`div`64)
+ mh = fromIntegral (FT.height m`div`64)
+ mw = fromIntegral (FT.width m`div`64)
+ k (dx + adv) (insert c (CellCoords dx 0
+ (let lw = bearX + mw`div`2 in
+ CellMetrics lw (adv-lw) (mh-bearY) bearY)
+ (let lw = mw`div`2 in
+ CellMetrics lw (mw-lw) (mh-bearY) bearY)) ret)
+
return (StringImage sizeX sizeY (V.unsafeFromForeignPtr0 ret (sizeX*sizeY)) cs)
deriving instance Show FTBMP.FT_Bitmap
D scripts/autocommit => scripts/autocommit +0 -8
@@ 1,8 0,0 @@
-#!/bin/bash
-git add -A
-git commit -m "Autocommit on $(LANG= date)"
-if [ "$NOTIFY_ON_SUCCESS" == true ]; then
- notify-send "Build successful"
-fi
-
-
A scripts/changelog => scripts/changelog +43 -0
@@ 0,0 1,43 @@
+#!/bin/bash
+case "$#" in
+ 0)
+ cat >&2 <<EOF
+Usage: $0 <package>
+ OR $0 <package> <commit>...
+
+Show a changelog for the given package. In the second form, include
+additional commits into that changelog.
+
+This script uses git notes ('man git notes') to identify commits that
+belong to a particular changeset. This method allows some commits to
+be included into multiple changelogs, if need be.
+
+EOF
+ ;;
+ 1)
+ if [ -z "$SHOW_ALL" ]; then
+ git_log_options=( --show-notes --grep="changelog-$1" --pretty=format:" - %s" )
+ else
+ git_log_options=( --pretty=format:" - (%N) %s" )
+ fi
+ printf 'Revision history for %s\n===============\n' "$1"
+
+ git tag | grep "^\\(package\\|release\\)-$1-[0-9]" | sort -t- -k3V | tail -n+"${2:-1}" | {
+ read oldver
+ while read ver; do
+ printf '### %s'$'\n' "$oldver"
+ git log "${git_log_options[@]}" "$oldver".."$ver" | grep -v "Successful build\|Autocommit"
+ printf '### %s'$'\n' "$ver"
+ oldver="$ver"
+ done
+ } | uniq | tac \
+ | sed -n '/^###/{h;:loop;n;/^###/{H;bloop}};x;s/\n###/ \//g;s/^\(###.*\)$/\n\1\n/m;p;x;:loopa;/^ /{p;n;/^###/{h;bloop;};bloopa;};' \
+ | less
+ ;;
+ *)
+ for commit in "${@:2}"; do
+ git notes append -m "changelog-$1" "$commit"
+ done;;
+esac
+
+
M scripts/ci/pages => scripts/ci/pages +5 -5
@@ 9,7 9,7 @@ elif has_cmd scss; then scss=scss
fi
mkdir -p public/doc && {
- packages=( )
+ packages=( "$@" )
ispackage=
while read line; do
case "$line" in
@@ 38,7 38,7 @@ mkdir -p public/doc && {
<body>
<div id="package-header">
<ul class="links">
- <li><a href="https://git.curly-lang.org/marc/curly">Source repository</a></li>
+ <li><a href="https://github.com/lih/BHR/curly">Source repository</a></li>
<li><a href="../index.html">Back to the main page</a></li>
</ul>
<div class="caption">Curly packages</div></div>
@@ 66,9 66,9 @@ EOF
for exe in "${executables[@]}"; do
version="$(sed -n 's/^version:\s*//p' "$exe/$exe.cabal")"
full="$exe-$version"
- if [ ! -e public/pkg/$full.tar.xz ]; then
- curl -L "https://github.com/lih/stack-libs/releases/download/release-$full/$exe.linux.x86_64.tar.xz" \
- > public/pkg/$full.tar.xz
+ if [ ! -e "public/pkg/$full.tar.xz" ]; then
+ curl -L "https://github.com/lih/stack-libs/releases/download/release-$exe-$version/$exe.linux.x86_64.tar.xz" \
+ > "public/pkg/$full.tar.xz"
fi
ln -fs $full.tar.xz public/pkg/$exe.tar.xz
printf '<li><a href="pkg/%s.tar.xz">%s.tar.xz</a></li>\n' "$exe" "$full"
D scripts/do-release => scripts/do-release +0 -8
@@ 1,8 0,0 @@
-#!/bin/bash
-git clone . -b release stack.rel
-( cd stack.rel
- git pull origin master
- git push )
-rm -rf stack.rel
-
-
A scripts/git-stitch => scripts/git-stitch +15 -0
@@ 0,0 1,15 @@
+#!/bin/bash
+set -ue
+commit="$1"
+git checkout master
+git checkout -b master-new
+git merge "$commit"
+git rebase -i master
+git checkout history
+git merge "$commit"
+git merge --no-ff -m "Commit-burger from master" master-new
+git checkout autocommit
+git rebase history
+git checkout master
+git merge master-new
+git branch -d master-new
M scripts/notify-build-success => scripts/notify-build-success +1 -6
@@ 1,10 1,5 @@
#!/bin/bash
notify-send "Stack: Compilation completed successfully"
-if [ ! -e .autocommit ]; then
- git branch autocommit || :
- git clone -b autocommit . .autocommit
-fi
-GIT_DIR=.autocommit/.git git commit -am "Successful build (on $(date))"
-GIT_DIR=.autocommit/.git git push
+git commit -am "Successful build (on $(date))"
notify-send "New commit pushed to the autocommit branch"
D scripts/update-deps => scripts/update-deps +0 -35
@@ 1,35 0,0 @@
-#!/bin/bash
-IFSBAK="$IFS"
-declare -A PKGS
-while read pkg ver; do
- PKGS[$pkg]="$ver"
-done < <(stack ls dependencies)
-for file in */*.cabal; do
- while IFS= read line; do
- case "$line" in
- *build-depends:*)
- prefix="${line%%build-depends:*}"
- IFS="$IFS,&" deps=( ${line#*build-depends:} ) IFS="$IFSBAK"
- full_deps=( )
- for dep in "${deps[@]}"; do
- case "$dep" in
- '>'*|'<'*|'') :;;
- *)
- ver="${PKGS[$dep]}"
- IFS=. vern=( $ver ) IFS="$IFSBAK"
- if [ "$RAW_DEPS" != '' ] || [ "${vern[0]}" == "" ]; then
- full_deps+=( "$dep" )
- else
- full_deps+=( "$dep >=${vern[0]}.${vern[1]} && <${vern[0]}.$((vern[1]+1))" )
- fi
- ;;
- esac
- done
- IFS=$'\n' full_deps=( $(printf "%s\n" "${full_deps[@]}" | sort) ) IFS="$IFSBAK"
- IFS=,; printf "%sbuild-depends: %s\n" "$prefix" "${full_deps[*]}"; IFS="$IFSBAK"
- ;;
- *) printf "%s\n" "$line";;
- esac
- done < "$file" > "$file.new"
- mv "$file"{.new,}
-done
M stack.yaml => stack.yaml +7 -1
@@ 35,11 35,17 @@ resolver: lts-9.10
# A package marked 'extra-dep: true' will only be built if demanded by a
# non-dependency (i.e. a user package), and its test suites and benchmarks
# will not be run. This is useful for tweaking upstream packages.
-packages:
+packages: []
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+extra-deps:
- ./curly
+<<<<<<< HEAD
# Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3)
extra-deps:
+=======
+>>>>>>> f978fa3cb9c33a7895a1410e14a86e07f5be518b
- ./capricon
- ./curly-gateway
- ./logos
A stack.yaml.lock => stack.yaml.lock +33 -0
@@ 0,0 1,33 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+# https://docs.haskellstack.org/en/stable/lock_files
+
+packages:
+- completed:
+ pantry-tree:
+ sha256: 383c2297d0981a273480b929a460acaaae92ac6287217fcff0c88a23aa0b548e
+ size: 1202
+ hackage: AES-0.2.9@sha256:9e51c1b1687fe35ccd0f2983e861b5b0441399803ff76b192530984724a68d6f,1315
+ original:
+ hackage: AES-0.2.9
+- completed:
+ pantry-tree:
+ sha256: f0816849440eafbe788d34281c6edb8a2561d62a6694416d13aaca1223f418a0
+ size: 1326
+ hackage: kademlia-1.1.0.0@sha256:a50d13bc985acda13e17e2b5c6390f18c5362cc15ea38b762a3944c31e86f215,3222
+ original:
+ hackage: kademlia-1.1.0.0
+- completed:
+ pantry-tree:
+ sha256: 048e1f6c312f4d379be18a949db04112ae430ddcd1a8ca31c629dfb941ce42c3
+ size: 3188
+ hackage: GLFW-0.5.2.5@sha256:06853ef61427078b773ff2043e1118aa53e42d08e5331e3d2b808705c75b6ffd,3444
+ original:
+ hackage: GLFW-0.5.2.5
+snapshots:
+- completed:
+ sha256: ba6ba39d048b5a2054142209f00e7e456e30081c03ea72b6135983633b234535
+ size: 535263
+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/9/10.yaml
+ original: lts-9.10