Skip to content

GitLab

Vous avez reçu un message "Your GitLab account has been locked ..." ? Pas d'inquiétude : lisez cet article https://docs.gricad-pages.univ-grenoble-alpes.fr/help/unlock/

Commit 92042b21 authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Start updating the CaPriCon interpreter to enable "automatic universes"

parent 6b457fd3
Hide whitespace changes
Inline Side-by-side
Showing with 108 additions and 165 deletions
capricon/exe/CaPriCon_Engine.hs
View file @ 92042b21
......@@ -177,7 +177,13 @@ main = do
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
......@@ -188,71 +194,3 @@ postMessage msg = liftIO $ JS.ffi "(function (m) { postMessage(m); })" (JS.toAny
capriconObject :: JS.JSAny
capriconObject = JS.constant "CaPriCon"
-- maybe unit JS.focus =<< JS.elemById "content-scroll"
-- JS.wait 200
-- let 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"] $ \[inpCons] -> void $ do
-- let toggleActive = do
-- JS.toggleClass root' "active"
-- JS.focus inpCons
-- JS.onEvent closeBtn JS.Click (const toggleActive)
-- JS.onEvent trig JS.Click $ \_ -> toggleActive
-- withSubElems root ["capricon-input"] $ \[inpMain] -> do
-- 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
-- -- JS.alert ("Running "+fromString text)
-- (state',_) <- runWordsState (stringWords text) state
-- let onEnter x = \case
-- JS.KeyData 13 False False False False -> x
-- _ -> return ()
-- runCode inp = do
-- Just v <- JS.getValue inp
-- (_,x) <- runWordsState (stringWords v) state'
-- JS.setProp out "textContent" (toString x)
-- return v
-- JS.onEvent inp JS.KeyPress $ onEnter $ void $ runCode inp
-- JS.onEvent inpMain JS.KeyPress $ onEnter $ do
-- v <- runCode inpMain
-- JS.setClass root' "active" True
-- JS.focus inp
-- JS.setProp inp "value" v
-- JS.setClass inpMain "ready" True
-- next state' ""
-- cloneNode :: MonadIO m => JS.Elem -> m JS.Elem
-- cloneNode x = liftIO $ JS.ffi "(function (n) { return n.cloneNode(true); })" x
capricon/src/CaPriCon/Run.hs
View file @ 92042b21
......@@ -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
......@@ -21,7 +21,7 @@ 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 (ContextTerm str (COCAxiom str))
| COCNull | COCError str
| COCConvertible (Maybe (Int,Int))
| COCAlgebraic (Algebraic str)
......@@ -49,10 +49,10 @@ 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+">:"+
COCExpr (ContextTerm d e) -> -- "<"+show d+">:"+
toRaw $ showNode' dir (map (second snd) $ takeLast d (freshContext ctx)) e
COCNull -> "(null)"
COCError e -> "<!"+e+"!>"
......@@ -172,13 +172,13 @@ literate = liftA2 (\pref r -> pref + [Left (TextComment $ fromString r)])
data COCState str = COCState {
_endState :: Bool,
_context :: [(str,Node str (COCAxiom str))],
_context :: Env str (ContextTerm 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 (ContextTerm 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 })
......@@ -188,11 +188,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 ()
=> (ContextTerm str (COCAxiom str) -> ContextTerm str (COCAxiom str)) -> m ()
modifyAllExprs f = do
let modStack (StackCOC (COCExpr e)) = StackCOC (COCExpr (f e))
modStack (StackDict d) = StackDict (map modStack d)
......@@ -201,7 +201,7 @@ 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 (ContextTerm str (COCAxiom str) -> ContextTerm str (COCAxiom str),Env str (ContextTerm str (COCAxiom str))) -> m ()
modifyCOCEnv Nothing = unit
modifyCOCEnv (Just (modE,ctx)) = do
runExtraState (context =- ctx)
......@@ -227,7 +227,7 @@ 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 (ContextTerm 0 e)):StackSymbol s:st -> StackCOC (COCExpr (ContextTerm 0 (Cons (Ap (Axiom e s) [])))):st
st -> st
runCOCBuiltin COCB_Format = do
......@@ -279,7 +279,7 @@ runCOCBuiltin COCB_Ap = do
runCOCBuiltin (COCB_Bind close bt) = do
ctx <- runExtraState (getl context)
let dctx = length ctx
setVal (StackCOC (COCExpr e@(ContextNode d _)))
setVal (StackCOC (COCExpr e@(ContextTerm d _)))
| d==dctx || not close
, Just e' <- runInContext ctx (mkBind bt e) = StackCOC (COCExpr e')
setVal (StackDict dict) = StackDict (map setVal dict)
......@@ -307,13 +307,13 @@ runCOCBuiltin COCB_MatchTerm = do
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'))
runStackState $ put (StackCOC (COCExpr (ContextTerm (d+1) (Cons (Ap (Sym 0) []))))
:StackCOC (COCExpr (ContextTerm (d+1) 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'))
runStackState $ put (StackCOC (COCExpr (ContextTerm (d+1) (Cons (Ap (Sym 0) []))))
:StackCOC (COCExpr (ContextTerm (d+1) e'))
:st')
Cons (Ap h []) -> do
case h of
......@@ -321,21 +321,21 @@ runCOCBuiltin COCB_MatchTerm = do
| 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'))
tailCall onMu $ runStackState $ put (StackCOC (COCExpr (ContextTerm d a'))
:st')
Axiom t a -> tailCall onAxiom $ do
runStackState $ put (StackSymbol a
:StackCOC (COCExpr (ContextNode 0 t))
:StackCOC (COCExpr (ContextTerm 0 t))
:st')
Cons (Ap h args) -> tailCall onApply $ do
runStackState $ put (StackList (map (StackCOC . COCExpr . ContextNode d) args)
:StackCOC (COCExpr (ContextNode d (Cons (Ap h []))))
runStackState $ put (StackList (map (StackCOC . COCExpr . ContextTerm d) args)
:StackCOC (COCExpr (ContextTerm d (Cons (Ap h []))))
:st')
Universe n -> tailCall onUniverse $ runStackState $ put (StackInt n:st')
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 (ContextTerm d e)):st' -> runMatch onUniverse onLambda onProduct onApply onMu onVar onAxiom d e st'
onUniverse:onLambda:onProduct:onApply:onMu:onVar:onAxiom:StackCOC (COCExpr (ContextTerm d e)):st' -> runMatch onUniverse onLambda onProduct onApply onMu onVar onAxiom d e st'
_ -> unit
runCOCBuiltin COCB_TypeOf = do
......@@ -418,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 (ContextTerm d e)):t -> StackCOC (COCAlgebraic (fromTerm e ([],takeLast d ctx))):t
st -> st
runCOCBuiltin COCB_GetShowDir = do
......@@ -435,7 +435,7 @@ 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 ->
x:StackCOC (COCExpr (ContextTerm d e)):StackCOC (COCDir dir):t ->
StackCOC (COCDir (insert e (map fst (takeLast d ctx),x) dir)):t
st -> st
......
capricon/src/Data/CaPriCon.hs
View file @ 92042b21
{-# LANGUAGE UndecidableInstances, OverloadedStrings, NoMonomorphismRestriction, DeriveGeneric, ConstraintKinds #-}
module Data.CaPriCon(
-- * Expression nodes
IsCapriconString(..),BindType(..),Node(..),ApHead(..),Application(..),ContextNode(..),Env,COCExpression(..),
IsCapriconString(..),BindType(..),Term(..),ApHead(..),Application(..),ContextTerm(..),Env,DependentLogic(..),
-- ** Managing De Bruijin indices
adjust_depth,adjust_telescope_depth,inc_depth,free_vars,is_free_in,
-- ** Expression directories
......@@ -51,30 +51,31 @@ 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)]
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,11 +85,18 @@ 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
insertHypBefore :: Maybe str -> str -> e -> m (e -> e,Env str 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
instance (Show a,IsCapriconString str,Monad m,MonadReader (Env str (Term str a)) m) => DependentLogic str (MaybeT m) (Term str a) where
type Axiom (Term str a) = a
type Binding (Term str a) = TypeTerm str a
mkUniverse = pure . Universe
mkVariable v = hypIndex v <&> \i -> Cons (Ap (Sym i) [])
......@@ -103,7 +111,7 @@ instance (Show a,IsCapriconString str,Monad m,MonadReader (Env str a) m) => COCE
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
conversionDelta a b = return (convertDelta a b)^.maybeT
substHyp h x = do
i <- hypIndex h
......@@ -127,54 +135,51 @@ instance (Show a,IsCapriconString str,Monad m,MonadReader (Env str a) m) => COCE
GT -> second (adjust_depth (adj i)) x:k (i+1))
(\_ -> []) ctx 0)
hypIndex :: (IsCapriconString str,MonadReader (Env 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)
data ContextTerm str a = ContextTerm SymbolRef (Term 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
instance (ListSerializable a,ListSerializable str) => ListSerializable (ContextTerm str a)
instance (ListFormat a,ListFormat str) => ListFormat (ContextTerm str a)
restrictEnv :: SymbolRef -> [a] -> [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
instance (Show a,IsCapriconString str,MonadReader (Env str (Term str a)) m,Monad m) => DependentLogic str (MaybeT m) (ContextTerm str a) where
type Axiom (ContextTerm str a) = a
type Binding (ContextTerm str a) = Term str 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)
mkUniverse u = ask >>= \ctx -> ContextTerm (length ctx)<$>mkUniverse u
mkVariable i = local (dropWhile ((/=i) . fst)) (ask >>= \ctx -> ContextTerm (length ctx)<$>mkVariable i)
mkBind t ce@(ContextTerm de e) | de>0 = ContextTerm (de-1) <$> local (restrictEnv de) (mkBind t e)
| otherwise = return ce
mkApply (ContextNode df f) (ContextNode dx x) = do
mkApply (ContextTerm df f) (ContextTerm 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) =
ContextTerm dm <$> mkApply (inc_depth (dm-df) f) (inc_depth (dm-dx) x)
mkMu (ContextTerm d e) = ContextTerm d <$> local (restrictEnv d) (mkMu e)
checkType (ContextTerm d e) = ContextTerm d <$> local (restrictEnv d) (checkType e)
conversionDelta (ContextTerm da a) (ContextTerm db b) =
let dm = max da db in
local (restrictEnv dm)
$ conversionDelta (inc_depth (dm-da) a) (inc_depth (dm-db) b)
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 (ContextTerm d e) = ask <&> \l -> ContextTerm (length l) (inc_depth (length l-d) e)
pullTerm (Just v) (ContextTerm d 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)
return (ContextTerm d' $ inc_depth (d'-d) e)
substHyp h vh = do
ContextNode dm vh' <- pullTerm (Just h) vh
first (\f cv@(ContextNode d v) ->
ContextTerm dm vh' <- pullTerm (Just h) vh
first (\f cv@(ContextTerm d v) ->
if d <= dm then cv
else ContextNode (d-1) (inc_depth (d-dm) $ f $ inc_depth (dm-d) v)) <$>
else ContextTerm (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) ->
ContextTerm dh th' <- pullTerm h cth'
first (\f cx@(ContextTerm d x) ->
if d <= dh then cx
else ContextNode (d+1) (inc_depth (d-dh) $ f $ inc_depth (dh-d) x))
else ContextTerm (d+1) (inc_depth (d-dh) $ f $ inc_depth (dh-d) x))
<$> insertHypBefore h h' th'
data NodeDir str ax a = NodeDir
......@@ -227,7 +232,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 +255,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
......@@ -304,7 +309,7 @@ adjust_depth f = go 0
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 :: Term 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
......@@ -314,7 +319,7 @@ free_vars (Cons a) = freeA a
freeA (Ap (Axiom _ _) xs) = foldMap free_vars xs
free_vars _ = zero
is_free_in :: Int -> Node str a -> Bool
is_free_in :: Int -> Term str a -> Bool
is_free_in = map2 not go
where go v (Bind _ _ t e) = go v t && go (v+1) e
go v (Cons a) = go_a v a
......@@ -323,9 +328,9 @@ is_free_in = map2 not go
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
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
......@@ -462,7 +467,7 @@ 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))
......@@ -508,7 +513,7 @@ showNode' dir = go 0
| 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 (Env 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
......@@ -532,12 +537,12 @@ type_of = yb maybeT . go
rec_subst (y:t) (Bind Prod _ tx e) = do
ty <- go y
_ <- return (convertible tx ty)^.maybeT
_ <- return (convertDelta tx ty)^.maybeT
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 :: MonadReader (Env str (Term str a)) m => Term str a -> m (Maybe (Term str a))
mu_type (inc_depth 1 -> root_type) = yb maybeT $ go 0 root_type
where
root_args = go' root_type
......@@ -586,8 +591,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)
convertDelta :: Term str a -> Term str a -> Maybe (Int,Int)
convertDelta = \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)
......
capricon/src/Data/CaPriCon/Extraction.hs
View file @ 92042b21
......@@ -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],Env 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],Env 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
, 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],Env 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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment