examples/tutorial.pdf
build/
build/**
+examples/.build
+examples/*.o
+examples/*.hi
+
+
coqc := coqc -noglob -opt
coqfiles := $(shell find src -name \*.v | grep -v \\\#)
allfiles := $(coqfiles) $(shell find src -name \*.hs | grep -v \\\#)
+coq_version := $(shell coqc -v | head -n1 | sed 's_.*version __' | sed 's_ .*__')
+coq_version_wanted := 8.3pl2-tracer
default: all
cd build; $(MAKE) -f Makefile.coq OPT="-opt -dont-load-proofs" All.vo
build/CoqPass.hs: $(allfiles)
+ifeq ($(coq_version),$(coq_version_wanted))
make build/Makefile.coq
cd build; $(MAKE) -f Makefile.coq OPT="-opt -dont-load-proofs" ExtractionMain.vo
cd build; $(MAKE) -f Makefile.coq Extraction.vo
cat src/Extraction-prefix.hs > build/CoqPass.hs
cat build/Extraction.hs | grep -v '^module' | grep -v '^import' >> build/CoqPass.hs
+else
+ @echo
+ @echo ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ @echo ++ YOU DO NOT HAVE COQ VERSION $(coq_version_wanted) INSTALLED ++
+ @echo ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ @echo
+ @echo Therefore, I am going to "git pull -f" from the coq-extraction-baked-in
+ @echo branch of the repository.
+ @echo
+ git pull -f http://git.megacz.com/coq-hetmet.git coq-extraction-baked-in:master
+endif
+
build/Makefile.coq: $(coqfiles) src/categories/src
mkdir -p build
clean:
rm -rf build
+examples/test.pdf:
+ ../../../inplace/bin/ghc-stage2 GArrowTikZ.hs
+ ./GArrowTikZ > test.tex
+ pdflatex test.tex
+ open test.pdf
+
+examples/doc/index.html:
+ mkdir -p examples/doc
+ haddock --html Unify.hs
+ open Unify.html
+
+
merged:
mkdir -p .temp
cd src; for A in *.v; do cat $$A | grep -v '^Require Import' > ../.temp/`echo $$A | sed s_\\\\.v_._`; done
- cd src/categories/src; for A in *.v; do cat $$A | grep -v '^Require Import' > ../../../.temp/`echo $$A | sed s_\\\\.v_._`; done
+ cd src/categories/src; for A in *.v; do cat $$A | \
+ grep -v '^Require Import' > ../../../.temp/`echo $$A | sed s_\\\\.v_._`; done
cp src/Banner.v .temp/GArrows.v
cd .temp; grep '^Require Import ' ../src/All.v | sed 's_Require Import _echo;echo;echo;echo;echo;cat _' | bash >> GArrows.v
cd .temp; time $(coqc) -dont-load-proofs -verbose GArrows.v
-{-# OPTIONS_GHC -XModalTypes -XMultiParamTypeClasses -ddump-types -XNoMonoPatBinds -XFlexibleInstances -XGADTs -XUndecidableInstances #-}
+{-# OPTIONS_GHC -XModalTypes -XMultiParamTypeClasses -ddump-types -XNoMonoPatBinds -XFlexibleInstances -XGADTs -XUndecidableInstances -XDatatypeContexts #-}
module BiGArrow
where
-import GHC.HetMet.GArrow
+import Control.GArrow
import Control.Category
import Control.Arrow
import Prelude hiding ( id, (.) )
--- /dev/null
+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}
+module BitSerialHardware(Wire,BitSerialHardwarePrimitives(..)) where
+import Control.GArrow
+import Control.Category
+import GArrowPretty
+import Prelude hiding (id, (.))
+import Text.PrettyPrint.HughesPJ
+import GArrowPortShape
+import GArrowSkeleton
+import GArrowTikZ
+
+------------------------------------------------------------------------------
+-- Bit-Serial Hardware Primitives
+
+data Wire = Wire
+
+class (GArrowSwap v (,) (), GArrowDrop v (,) (), GArrowCopy v (,) (), GArrowLoop v (,) ()) =>
+ BitSerialHardwarePrimitives v where
+ high :: v () Wire
+ low :: v () Wire
+
+ not :: v Wire Wire
+ xor :: v (Wire,Wire) Wire
+ or :: v (Wire,Wire) Wire
+ and :: v (Wire,Wire) Wire
+ mux2 :: v (Wire,(Wire,Wire)) Wire
+ maj3 :: v (Wire,(Wire,Wire)) Wire
+ reg :: v Wire Wire
+
+ loop :: [Bool] -> v () Wire
+ fifo :: Int -> v Wire Wire
+
+ probe :: Int -> v Wire Wire
+ oracle :: Int -> v () Wire
+
+instance BitSerialHardwarePrimitives SourceCode where
+ high = SC False $ text "high"
+ low = SC False $ text "low"
+ not = SC False $ text "not"
+ xor = SC False $ text "xor"
+ or = SC False $ text "or"
+ and = SC False $ text "and"
+ mux2 = SC False $ text "mux2"
+ maj3 = SC False $ text "maj3"
+ reg = SC False $ text "reg"
+ loop vals = SC False $ text "loop" <+> (brackets $ hcat $ punctuate comma $ map (text . show) vals)
+ fifo len = SC False $ text "fifo" <+> (text . show) len
+ probe id = SC False $ text "probe" <+> (text . show) id
+ oracle id = SC False $ text "oracle" <+> (text . show) id
+
+instance BitSerialHardwarePrimitives (GArrowSkeleton Opaque) where
+ reg = GAS_misc reg'
+ where reg' = MkOpaque "reg" $
+ do x <- freshM
+ return $ GASPortPassthrough (PortFree x) (PortFree x) reg'
+ xor = GAS_misc xor'
+ where xor' = MkOpaque "xor" $
+ do x <- freshM
+ return $ GASPortPassthrough (PortTensor (PortFree x) (PortFree x)) (PortFree x) xor'
+ high = undefined
+ low = undefined
+ not = undefined
+ or = undefined
+ and = undefined
+ mux2 = undefined
+ maj3 = undefined
+ loop vals = undefined
+ fifo len = undefined
+ probe id = undefined
+ oracle id = undefined
--- /dev/null
+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}
+module BitSerialHardware(Wire,BitSerialHardwarePrimitives(..)) where
+import Control.GArrow
+import Control.Category
+import GArrowPretty
+import Prelude hiding (id, (.))
+import Text.PrettyPrint.HughesPJ
+import GArrowPortShape
+import GArrowSkeleton
+import GArrowTikZ
+
+------------------------------------------------------------------------------
+-- Bit-Serial Hardware Primitives
+
+data Wire = Wire
+
+class (GArrowSwap v (,) (), GArrowDrop v (,) (), GArrowCopy v (,) (), GArrowLoop v (,) ()) =>
+ BitSerialHardwarePrimitives v where
+ high :: v () Wire
+ low :: v () Wire
+
+ not :: v Wire Wire
+ xor :: v (Wire,Wire) Wire
+ or :: v (Wire,Wire) Wire
+ and :: v (Wire,Wire) Wire
+ mux2 :: v (Wire,(Wire,Wire)) Wire
+ maj3 :: v (Wire,(Wire,Wire)) Wire
+ reg :: v Wire Wire
+
+ loop :: [Bool] -> v () Wire
+ fifo :: Int -> v Wire Wire
+
+ probe :: Int -> v Wire Wire
+ oracle :: Int -> v () Wire
+
+instance BitSerialHardwarePrimitives SourceCode where
+ high = SC False $ text "high"
+ low = SC False $ text "low"
+ not = SC False $ text "not"
+ xor = SC False $ text "xor"
+ or = SC False $ text "or"
+ and = SC False $ text "and"
+ mux2 = SC False $ text "mux2"
+ maj3 = SC False $ text "maj3"
+ reg = SC False $ text "reg"
+ loop vals = SC False $ text "loop" <+> (brackets $ hcat $ punctuate comma $ map (text . show) vals)
+ fifo len = SC False $ text "fifo" <+> (text . show) len
+ probe id = SC False $ text "probe" <+> (text . show) id
+ oracle id = SC False $ text "oracle" <+> (text . show) id
+
+instance BitSerialHardwarePrimitives (GArrowSkeleton Opaque) where
+ reg = GAS_misc reg'
+ where reg' = MkOpaque "reg" $
+ do x <- freshM
+ return $ GASPortPassthrough (PortFree x) (PortFree x) reg'
+ xor = GAS_misc xor'
+ where xor' = MkOpaque "xor" $
+ do x <- freshM
+ return $ GASPortPassthrough (PortTensor (PortFree x) (PortFree x)) (PortFree x) xor'
+ high = undefined
+ low = undefined
+ not = undefined
+ or = undefined
+ and = undefined
+ mux2 = undefined
+ maj3 = undefined
+ loop vals = undefined
+ fifo len = undefined
+ probe id = undefined
+ oracle id = undefined
{-# OPTIONS_GHC -XModalTypes -ddump-types -XNoMonoPatBinds -XMultiParamTypeClasses -XTypeOperators #-}
module CircuitExample
where
-import GHC.HetMet.CodeTypes hiding ((-))
-import GHC.HetMet.GArrow
+import Control.GArrow
+import GHC.HetMet.GuestLanguage hiding ((-))
import Control.Category
import Prelude hiding ( id, (.) )
--- /dev/null
+{-# OPTIONS_GHC -XModalTypes -fflatten -funsafe-skolemize -dcore-lint -XScopedTypeVariables -fsimpleopt-before-flatten #-}
+module Demo ({-sample1,sample2,-}sample5,sample6) where
+
+sample5 :: forall c . (Int -> <{Int}>@c) -> <{Int -> Int -> Int}>@c -> <{Int -> Int}>@c
+sample5 const <[ (*) ]> =
+ <{ \y ->
+ let foo = (~~(const 3) * foo) * y
+ in foo }>
+
+sample6 :: forall c . (Int -> <{Int}>@c) -> <{Int -> Int -> Int}>@c -> <{Int -> Int}>@c
+sample6 const <{ (*) }> = pow 6
+ where
+ --pow :: Int -> <{ Int -> Int }>@a
+ pow 0 = <{ \x -> ~~(const 1) }>
+ pow 1 = <{ \x -> x }>
+ pow n = <{ \x -> x * ~~(pow (n - 1)) x }>
+
+demo2 ::
+ forall c .
+ (Int -> <{Int}>@c) ->
+ <{Int -> Int -> Int}>@c ->
+ <{Int -> Int}>@c
+
+demo2 const mult =
+ <{ \y ->
+ ~~mult
+ (~~(const 1))
+ (~~mult y y)
+ }>
+
+
+
+
+
+
+
+{-
+demo const mult =
+ <{ \y ->
+ ~~mult
+ (~~mult (~~mult y y) (~~mult y y))
+ (~~mult (~~mult y y) (~~mult y y))
+ }>
+-}
+
+
+
+{-
+demo const mult =
+ <{ \y -> ~~(foo 4) }>
+ where
+ foo 0 = const (12::Int)
+ foo n = <{ let bar = ~~(foo (n-1))
+ in ~~mult bar bar
+ }>
+
+-}
+
+
+
+{-
+demo const mult =
+ <{ \y -> ~~(foo 3) }>
+ where
+ foo 0 = const (12::Int)
+ foo n = <{ let recurs = ~~(foo (n-1))
+ in ~~mult recurs recurs
+ }>
+
+-}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+{-
+demo const mult =
+ <{ \y -> ~~(foo 2 <{y}>) }>
+ where
+ foo 0 y = const (12::Int)
+ foo n y = <{ let recurs = ~~(foo (n-1) y)
+ in ~~mult recurs recurs
+ }>
+-}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+-- demo const mult = <{ \(y::Int) -> ~~mult y ~~(const 12) }>
+-- demo' n = <{ ~~mult ~~(demo' (n-1)) ~~(demo' (n-1)) }>
+-- golden
+{-
+demo const mult =
+ <{ \y ->
+ let twelve = ~~mult twelve y
+ in twelve }>
+-}
+
+{-
+demo const mult =
+ <{ \y -> let y = ~~(const 4) in ~~mult (~~mult y y) (~~mult y y) }>
+-}
+
+{-
+demo const mult =
+ <{ \(y::Int) ->
+ let four = ~~mult four ~~(const 4)
+-- twelve = {- {- ~~mult four -} ~~(const 12) -} four
+ in four
+ }>
+-}
+
+{-
+demo const mult =
+ <{ let twelve = ~~(const (12::Int))
+ in let four = ~~(const (4::Int))
+ in ~~mult four twelve }>
+-}
+
+{-
+demo const mult = demo' 3
+ where
+ demo' 0 = const 12
+ demo' 1 = const 12
+ demo' n = <{ ~~mult ~~(demo' (n-1)) ~~(demo' (n-2)) }>
+-}
+
+-- BUG
+--demo const mult = <{ \y -> ~~(demo' 0) }>
+-- where
+-- demo' 0 = const 4
+-- demo' n = const 4
--- /dev/null
+{-# LANGUAGE RankNTypes, FlexibleContexts, NoMonomorphismRestriction, ScopedTypeVariables #-}
+import System.IO
+import Control.Category
+import GArrowTikZ
+import GHC.HetMet.Private
+import GArrowSkeleton
+import GArrowPortShape
+import GArrowAssTypes
+import BitSerialHardware
+import qualified Demo
+
+tikzExample1 =
+ ga_copy >>>
+ ga_swap >>>
+ ga_first ga_drop >>>
+ ga_cancell
+
+tikzExample2 =
+ ga_uncancelr >>>
+ ga_first ga_copy >>>
+ ga_swap >>>
+ ga_second (ga_first ga_drop >>>
+ ga_cancell) >>>
+ ga_cancell
+
+oscillator =
+ ga_loopl (ga_first reg >>>
+ xor >>>
+ ga_copy)
+
+oconst :: Int -> Opaque () a
+oconst c = MkOpaque ("{\\large{"++(show c)++"}}") $
+ do x <- freshM
+ return $ GASPortPassthrough PortUnit (PortFree x) (oconst c)
+
+omult :: Opaque (a,a) a
+omult = MkOpaque "{\\large{*}}" $
+ do x <- freshM
+ return $ GASPortPassthrough (PortTensor (PortFree x) (PortFree x)) (PortFree x) omult
+
+main = do let const c = PGArrowD $ GAS_misc $ oconst c
+ let mult = PGArrowD $ GAS_misc omult
+
+ sample5 <- toTikZ $ beautify $ optimize $ unG (Demo.sample5 const mult)
+ putStrLn $ tikz_header ++ sample5 ++ tikz_footer
+ withFile ".build/sample5.tex" WriteMode (\file -> hPutStr file sample5)
+
+ sample1 <- toTikZ $ skelify' tikzExample1
+ --putStrLn $ tikz_header ++ sample1 ++ tikz_footer
+ withFile ".build/sample1.tex" WriteMode (\file -> hPutStr file sample1)
+
+ sample2 <- toTikZ $ skelify' tikzExample2
+ --putStrLn $ tikz_header ++ sample2 ++ tikz_footer
+ withFile ".build/sample2.tex" WriteMode (\file -> hPutStr file sample2)
+
+ sample3 <- toTikZ $ skelify'' oscillator
+ --putStrLn $ tikz_header ++ sample3 ++ tikz_footer
+ withFile ".build/sample3.tex" WriteMode (\file -> hPutStr file sample3)
+
+ sample6 <- toTikZ $ beautify $ optimize $ unG (Demo.sample6 const mult)
+ --putStrLn $ tikz_header ++ sample6 ++ tikz_footer
+ withFile ".build/sample6.tex" WriteMode (\file -> hPutStr file sample6)
{-# OPTIONS_GHC -XModalTypes -ddump-types -XNoMonoPatBinds -XFlexibleContexts #-}
module DotProduct
where
-import GHC.HetMet.CodeTypes hiding ((-))
+import GHC.HetMet.GuestLanguage hiding ((-))
import Prelude hiding ( id, (.) )
--------------------------------------------------------------------------------
--- /dev/null
+applyCircuit =
+ <[ \higherOrderCircuit -> \arg -> higherOrderCircuit arg ]>
--- /dev/null
+{-# LANGUAGE RankNTypes, FlexibleContexts, NoMonomorphismRestriction, ScopedTypeVariables #-}
+--
+-- |
+-- Module : GArrowAssTypes
+-- Copyright : none
+-- License : public domain
+--
+-- Maintainer : Adam Megacz <megacz@acm.org>
+-- Stability : experimental
+--
+-- | This module is a gigantic type inference hack; it redefines all of the
+-- ga_functions with a slightly more specific type whereby each type g
+-- which is a GArrow instance also has an *associated type* (GArrowTensor g)
+-- for its tensor and (GArrowUnit g) for its unit.
+--
+-- DO import this module without qualification if you plan on
+-- writing GArrow-expressions with as few annotations as possible.
+--
+-- DO NOT import this module without qualification if you plan on
+-- creating new instances of GArrow. Use "import qualified" or
+-- don't import it at all.
+--
+
+module GArrowAssTypes
+ (ga_copy
+ ,ga_drop
+ ,ga_swap
+ , module Control.GArrow
+ )
+ where
+import System.IO
+import qualified Control.GArrow as G
+import Control.GArrow hiding (ga_copy, ga_drop, ga_swap)
+
+{-
+ga_copy :: forall x . forall g . GArrowCopy g (GArrowTensor g) (GArrowUnit g) => g x (GArrowTensor g x x)
+ga_copy = G.ga_copy
+
+ga_drop :: forall x . forall g . GArrowDrop g (GArrowTensor g) (GArrowUnit g) => g x (GArrowUnit g)
+ga_drop = G.ga_drop
+
+ga_swap :: forall x y . forall g . GArrowSwap g (GArrowTensor g) (GArrowUnit g) => g (GArrowTensor g x y) (GArrowTensor g y x)
+ga_swap = G.ga_swap
+-}
+
+
+ga_copy :: forall x . forall g . GArrowCopy g (,) () => g x ((,) x x)
+ga_copy = G.ga_copy
+
+ga_drop :: forall x . forall g . GArrowDrop g (,) () => g x ()
+ga_drop = G.ga_drop
+
+ga_swap :: forall x y . forall g . GArrowSwap g (,) () => g ((,) x y) ((,) y x)
+ga_swap = G.ga_swap
+
+
+
--- /dev/null
+
+
+sample1 =
+ ga_copy >>>
+ ga_swap >>>
+ ga_first ga_drop >>>
+ ga_cancell
+
+-- from the paper
+sample2 =
+ ga_uncancelr >>>
+ ga_first ga_copy >>>
+ ga_swap >>>
+ ga_second (ga_first ga_drop >>>
+ ga_cancell) >>>
+ ga_cancell
+
--- /dev/null
+{-# LANGUAGE FunctionalDependencies, NoMonomorphismRestriction, MultiParamTypeClasses #-}
+module GArrowInclusion(GArrowInclusion(ga_inc)) where
+import Control.GArrow
+
+class GArrow g (**) u => GArrowInclusion g (**) u g' where
+ ga_inc :: g' x y -> g x y
--- /dev/null
+{-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleContexts, FlexibleInstances, TypeFamilies #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GArrowPortShape
+-- Copyright : none
+-- License : public domain
+--
+-- Maintainer : Adam Megacz <megacz@acm.org>
+-- Stability : experimental
+--
+-- | We cannot, at run time, query to find out the input and output
+-- port types of a GArrowSkeleton since Haskell erases types during
+-- compilation. Using Data.Typeable is problematic here because
+-- GAS_comp and GAS_loop{l,r} have an existential type.
+--
+-- In spite of this, we can determine the "shape" of the ports --
+-- which ports are of unit type, and which ports must be tensors. A
+-- GArrowPortShape is a GArrowSkeleton along with this
+-- information for certain nodes (the inference mechanism below adds
+-- it on every node).
+--
+module GArrowPortShape (GArrowPortShape(..), PortShape(..), detectShape, Detect(..), DetectM, freshM)
+where
+import Prelude hiding ( id, (.), lookup )
+import Control.Category
+import Control.GArrow
+import Unify
+import GArrowSkeleton
+import Control.Monad.State
+
+--
+-- | Please keep in mind that the "shapes" computed below are simply the
+-- least-complicated shapes that could possibly work. Just because a
+-- GArrowPortShape has an input port of shape (x,y)
+-- doesn't mean it couldn't later be used in a context where its input
+-- port had shape ((a,b),y)! However, you can be assured that it
+-- won't be used in a context where the input port has shape ().
+--
+data PortShape a = PortUnit
+ | PortTensor (PortShape a) (PortShape a)
+ | PortFree a
+
+instance Show a => Show (PortShape a) where
+ show PortUnit = "U"
+ show (PortTensor p1 p2) = "("++show p1++"*"++show p2++")"
+ show (PortFree x) = show x
+
+data GArrowPortShape m s a b =
+ GASPortPassthrough
+ (PortShape s)
+ (PortShape s)
+ (m a b)
+ | GASPortShapeWrapper
+ (PortShape s)
+ (PortShape s)
+ (GArrowSkeleton (GArrowPortShape m s) a b)
+
+--
+-- implementation below; none of this is exported
+--
+
+type UPort = PortShape UVar
+
+instance Unifiable UPort where
+ unify' (PortTensor x1 y1) (PortTensor x2 y2) = mergeU (unify x1 x2) (unify y1 y2)
+ unify' PortUnit PortUnit = emptyUnifier
+ unify' s1 s2 = error $ "Unifiable UPort got impossible unification case: "
+
+ replace uv prep PortUnit = PortUnit
+ replace uv prep (PortTensor p1 p2) = PortTensor (replace uv prep p1) (replace uv prep p2)
+ replace uv prep (PortFree x) = if x==uv then prep else PortFree x
+
+ inject = PortFree
+ project (PortFree v) = Just v
+ project _ = Nothing
+ occurrences (PortFree v) = [v]
+ occurrences (PortTensor x y) = occurrences x ++ occurrences y
+ occurrences PortUnit = []
+
+-- detection monad
+type DetectM a = State ((Unifier UPort),[UVar]) a
+
+shapes :: GArrowPortShape m UVar a b -> (UPort,UPort)
+shapes (GASPortPassthrough x y _) = (x,y)
+shapes (GASPortShapeWrapper x y _) = (x,y)
+
+unifyM :: UPort -> UPort -> DetectM ()
+unifyM p1 p2 = do { (u,vars) <- get
+ ; put (mergeU u $ unify p1 p2 , vars)
+ }
+
+freshM :: DetectM UVar
+freshM = do { (u,(v:vars)) <- get
+ ; put (u,vars)
+ ; return v
+ }
+
+-- recursive version of getU
+getU' :: Unifier UPort -> UPort -> PortShape ()
+getU' u (PortTensor x y) = PortTensor (getU' u x) (getU' u y)
+getU' _ PortUnit = PortUnit
+getU' u x@(PortFree v) = case Unify.getU u v of
+ Nothing -> PortFree () -- or x
+ Just x' -> getU' u x'
+
+resolveG :: Unifier UPort -> (GArrowPortShape m UVar a b) -> GArrowPortShape m () a b
+resolveG u (GASPortPassthrough x y m) = GASPortPassthrough (getU' u x) (getU' u y) m
+resolveG u (GASPortShapeWrapper x y g) = GASPortShapeWrapper (getU' u x) (getU' u y) (resolveG' g)
+ where
+ resolveG' :: GArrowSkeleton (GArrowPortShape m UVar) a b ->
+ GArrowSkeleton (GArrowPortShape m ()) a b
+ resolveG' (GAS_id ) = GAS_id
+ resolveG' (GAS_comp f g) = GAS_comp (resolveG' f) (resolveG' g)
+ resolveG' (GAS_first f) = GAS_first (resolveG' f)
+ resolveG' (GAS_second f) = GAS_second (resolveG' f)
+ resolveG' GAS_cancell = GAS_cancell
+ resolveG' GAS_cancelr = GAS_cancelr
+ resolveG' GAS_uncancell = GAS_uncancell
+ resolveG' GAS_uncancelr = GAS_uncancelr
+ resolveG' GAS_drop = GAS_drop
+ resolveG' GAS_copy = GAS_copy
+ resolveG' GAS_swap = GAS_swap
+ resolveG' GAS_assoc = GAS_assoc
+ resolveG' GAS_unassoc = GAS_unassoc
+ resolveG' (GAS_loopl f) = GAS_loopl (resolveG' f)
+ resolveG' (GAS_loopr f) = GAS_loopr (resolveG' f)
+ resolveG' (GAS_misc g ) = GAS_misc $ resolveG u g
+
+detectShape :: Detect m => GArrowSkeleton m a b -> GArrowPortShape m () a b
+detectShape g = runM (detect g)
+
+runM :: Detect m => DetectM (GArrowPortShape m UVar a b) -> GArrowPortShape m () a b
+runM f = let s = (emptyUnifier,uvarSupply)
+ g = evalState f s
+ (u,_) = execState f s
+ in resolveG u g
+
+class Detect m where
+ detect' :: m x y -> DetectM (GArrowPortShape m UVar x y)
+
+detect :: Detect m => GArrowSkeleton m a b -> DetectM (GArrowPortShape m UVar a b)
+detect (GAS_id ) = do { x <- freshM ; return $ GASPortShapeWrapper (PortFree x) (PortFree x) GAS_id }
+detect (GAS_comp f g) = do { f' <- detect f
+ ; g' <- detect g
+ ; unifyM (snd $ shapes f') (fst $ shapes g')
+ ; return $ GASPortShapeWrapper (fst $ shapes f') (snd $ shapes g') (GAS_comp (GAS_misc f') (GAS_misc g'))
+ }
+detect (GAS_first f) = do { x <- freshM
+ ; f' <- detect f
+ ; return $ GASPortShapeWrapper
+ (PortTensor (fst $ shapes f') (PortFree x))
+ (PortTensor (snd $ shapes f') (PortFree x))
+ (GAS_first (GAS_misc f'))
+ }
+detect (GAS_second f) = do { x <- freshM
+ ; f' <- detect f
+ ; return $ GASPortShapeWrapper
+ (PortTensor (PortFree x) (fst $ shapes f'))
+ (PortTensor (PortFree x) (snd $ shapes f'))
+ (GAS_second (GAS_misc f'))
+ }
+detect GAS_cancell = do { x <- freshM; return$GASPortShapeWrapper (PortTensor PortUnit (PortFree x)) (PortFree x) GAS_cancell }
+detect GAS_cancelr = do { x <- freshM; return$GASPortShapeWrapper (PortTensor (PortFree x) PortUnit) (PortFree x) GAS_cancelr }
+detect GAS_uncancell = do { x <- freshM; return$GASPortShapeWrapper (PortFree x) (PortTensor PortUnit (PortFree x)) GAS_uncancell }
+detect GAS_uncancelr = do { x <- freshM; return$GASPortShapeWrapper (PortFree x) (PortTensor (PortFree x) PortUnit) GAS_uncancelr }
+detect GAS_drop = do { x <- freshM; return$GASPortShapeWrapper (PortFree x) PortUnit GAS_drop }
+detect GAS_copy = do { x <- freshM
+ ; return $ GASPortShapeWrapper (PortFree x) (PortTensor (PortFree x) (PortFree x)) GAS_copy }
+detect GAS_swap = do { x <- freshM
+ ; y <- freshM
+ ; let x' = PortFree x
+ ; let y' = PortFree y
+ ; return $ GASPortShapeWrapper (PortTensor x' y') (PortTensor y' x') GAS_swap
+ }
+detect GAS_assoc = do { x <- freshM; y <- freshM; z <- freshM
+ ; let x' = PortFree x
+ ; let y' = PortFree y
+ ; let z' = PortFree z
+ ; return $ GASPortShapeWrapper
+ (PortTensor (PortTensor x' y') z')
+ (PortTensor x' (PortTensor y' z'))
+ GAS_assoc
+ }
+detect GAS_unassoc = do { x <- freshM; y <- freshM; z <- freshM
+ ; let x' = PortFree x
+ ; let y' = PortFree y
+ ; let z' = PortFree z
+ ; return $ GASPortShapeWrapper
+ (PortTensor x' (PortTensor y' z'))
+ (PortTensor (PortTensor x' y') z')
+ GAS_unassoc
+ }
+detect (GAS_loopl f) = do { x <- freshM
+ ; y <- freshM
+ ; z <- freshM
+ ; f' <- detect f
+ ; unifyM (fst $ shapes f') (PortTensor (PortFree z) (PortFree x))
+ ; unifyM (snd $ shapes f') (PortTensor (PortFree z) (PortFree y))
+ ; return $ GASPortShapeWrapper (PortFree x) (PortFree y) (GAS_loopl (GAS_misc f'))
+ }
+detect (GAS_loopr f) = do { x <- freshM
+ ; y <- freshM
+ ; z <- freshM
+ ; f' <- detect f
+ ; unifyM (fst $ shapes f') (PortTensor (PortFree x) (PortFree z))
+ ; unifyM (snd $ shapes f') (PortTensor (PortFree y) (PortFree z))
+ ; return $ GASPortShapeWrapper (PortFree x) (PortFree y) (GAS_loopr (GAS_misc f'))
+ }
+
+detect (GAS_misc f) = detect' f
+
--- /dev/null
+{-# LANGUAGE FunctionalDependencies, NoMonomorphismRestriction, MultiParamTypeClasses #-}
+module GArrowPretty(SourceCode(..),pprGArrow) where
+import Prelude hiding (id,(.))
+import Control.GArrow
+import Control.Category
+import Text.PrettyPrint.HughesPJ
+
+-- The Bool flag is to minimize the number of parentheses generated:
+-- it is true iff the principal connective is of lower precedence than
+-- juxtaposition
+data SourceCode a b = SC Bool Doc
+
+instance Category SourceCode where
+ id = SC False $ text "id"
+ (SC _ g) . (SC _ f) = SC True $ f <+> (text ">>>") $$ g
+
+instance GArrow SourceCode (,) () where
+ ga_first (SC x f) = SC True $ text "ga_first"
+ <+> if x then parens f else f
+ ga_second (SC x f) = SC True $ text "ga_second"
+ <+> if x then parens f else f
+ ga_cancell = SC False $ text "ga_cancell"
+ ga_cancelr = SC False $ text "ga_cancelr"
+ ga_uncancell = SC False $ text "ga_uncancell"
+ ga_uncancelr = SC False $ text "ga_uncancelr"
+ ga_assoc = SC False $ text "ga_assoc"
+ ga_unassoc = SC False $ text "ga_unassoc"
+
+instance GArrowSwap SourceCode (,) () where
+ ga_swap = SC False $ text "ga_swap"
+instance GArrowDrop SourceCode (,) () where
+ ga_drop = SC False $ text "ga_drop"
+instance GArrowCopy SourceCode (,) () where
+ ga_copy = SC False $ text "ga_copy"
+instance GArrowLoop SourceCode (,) () where
+ ga_loopl (SC x f) = SC True $ text "ga_loopl" <+> if x then parens f else f
+ ga_loopr (SC x f) = SC True $ text "ga_loopr" <+> if x then parens f else f
+
+pprGArrow :: SourceCode x y -> Doc
+pprGArrow (SC _ doc) = doc
+
--- /dev/null
+{-# LANGUAGE FunctionalDependencies, NoMonomorphismRestriction, MultiParamTypeClasses #-}
+module GArrowShow(GArrowShow) where
+import Control.GArrow
+
+class GArrow g (**) u => GArrowShow g (**) u where
+ ga_show :: g x y -> String
--- /dev/null
+{-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleContexts, FlexibleInstances, TypeFamilies, RankNTypes #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GArrowSkeleton
+-- Copyright : none
+-- License : public domain
+--
+-- Maintainer : Adam Megacz <megacz@acm.org>
+-- Stability : experimental
+--
+-- | Sometimes it is convenient to be able to get your hands on the
+-- explicit boxes-and-wires representation of a GArrow-polymorphic
+-- term. GArrowSkeleton lets you do that.
+--
+-- HOWEVER: technically this instance violates the laws (and RULEs)
+-- for Control.Category; the compiler might choose to optimize (f >>>
+-- id) into f, and this optimization would produce a change in
+-- behavior below -- you'd get (GAS_comp f GAS_id) instead of f. In
+-- practice this means that the user must be prepared for the skeleton
+-- TikZ diagram to be a nondeterministically-chosen boxes-and-wires
+-- diagram which is *equivalent to* the term, rather than structurally
+-- exactly equal to it.
+--
+-- A normal form theorem and normalization algorithm are being prepared.
+--
+module GArrowSkeleton (GArrowSkeleton(..), mkSkeleton, OptimizeFlag(..), optimize, beautify, skelify)
+where
+import Prelude hiding ( id, (.), lookup, repeat )
+import Control.Category
+import Control.GArrow
+import Unify
+import Control.Monad.State
+import GArrowInclusion
+
+data GArrowSkeleton m :: * -> * -> *
+ where
+ GAS_id :: GArrowSkeleton m x x
+ GAS_comp :: GArrowSkeleton m x y -> GArrowSkeleton m y z -> GArrowSkeleton m x z
+ GAS_first :: GArrowSkeleton m x y -> GArrowSkeleton m (x,z) (y,z)
+ GAS_second :: GArrowSkeleton m x y -> GArrowSkeleton m (z,x) (z,y)
+ GAS_cancell :: GArrowSkeleton m ((),x) x
+ GAS_cancelr :: GArrowSkeleton m (x,()) x
+ GAS_uncancell :: GArrowSkeleton m x ((),x)
+ GAS_uncancelr :: GArrowSkeleton m x (x,())
+ GAS_assoc :: GArrowSkeleton m ((x,y),z) (x,(y,z))
+ GAS_unassoc :: GArrowSkeleton m (x,(y,z)) ((x,y),z)
+ GAS_drop :: GArrowSkeleton m x ()
+ GAS_copy :: GArrowSkeleton m x (x,x)
+ GAS_swap :: GArrowSkeleton m (x,y) (y,x)
+ GAS_loopl :: GArrowSkeleton m (z,x) (z,y) -> GArrowSkeleton m x y
+ GAS_loopr :: GArrowSkeleton m (x,z) (y,z) -> GArrowSkeleton m x y
+ GAS_misc :: m x y -> GArrowSkeleton m x y
+
+instance Category (GArrowSkeleton m) where
+ id = GAS_id
+ g . f = GAS_comp f g
+
+instance GArrow (GArrowSkeleton m) (,) () where
+ ga_first = GAS_first
+ ga_second = GAS_second
+ ga_cancell = GAS_cancell
+ ga_cancelr = GAS_cancelr
+ ga_uncancell = GAS_uncancell
+ ga_uncancelr = GAS_uncancelr
+ ga_assoc = GAS_assoc
+ ga_unassoc = GAS_unassoc
+
+instance GArrowDrop (GArrowSkeleton m) (,) () where
+ ga_drop = GAS_drop
+
+instance GArrowCopy (GArrowSkeleton m) (,) () where
+ ga_copy = GAS_copy
+
+instance GArrowSwap (GArrowSkeleton m) (,) () where
+ ga_swap = GAS_swap
+
+instance GArrowLoop (GArrowSkeleton m) (,) () where
+ ga_loopl = GAS_loopl
+ ga_loopr = GAS_loopr
+
+type instance GArrowTensor (GArrowSkeleton m) = (,)
+type instance GArrowUnit (GArrowSkeleton m) = ()
+type instance GArrowExponent (GArrowSkeleton m) = (->)
+
+instance GArrowCopyDropSwapLoop (GArrowSkeleton m)
+
+instance GArrowInclusion (GArrowSkeleton m) (,) () m where
+ ga_inc = GAS_misc
+
+skelify :: (forall g . (GArrowCopyDropSwapLoop g, GArrowInclusion g (,) () m) => g x y) -> GArrowSkeleton m x y
+skelify = \g -> g
+
+--
+-- | Simple structural equality on skeletons. NOTE: two skeletons
+-- with the same shape but different types will nonetheless be "equal";
+-- there's no way around this since types are gone at runtime.
+--
+instance Eq ((GArrowSkeleton m) a b)
+ where
+ x == y = x === y
+ where
+ (===) :: (GArrowSkeleton m) a b -> (GArrowSkeleton m) c d -> Bool
+ (GAS_id ) === (GAS_id ) = True
+ (GAS_comp g f) === (GAS_comp g' f') = f===f' && g===g'
+ (GAS_first f) === (GAS_first f') = f===f'
+ (GAS_second f) === (GAS_second f') = f===f'
+ GAS_cancell === GAS_cancell = True
+ GAS_cancelr === GAS_cancelr = True
+ GAS_uncancell === GAS_uncancell = True
+ GAS_uncancelr === GAS_uncancelr = True
+ GAS_drop === GAS_drop = True
+ GAS_copy === GAS_copy = True
+ GAS_swap === GAS_swap = True
+ GAS_assoc === GAS_assoc = True
+ GAS_unassoc === GAS_unassoc = True
+ (GAS_loopl f) === (GAS_loopl f') = f === f'
+ (GAS_loopr f) === (GAS_loopr f') = f === f'
+ (GAS_misc _) === (GAS_misc _) = True -- FIXME
+ _ === _ = False
+
+data OptimizeFlag = DoOptimize | NoOptimize
+
+mkSkeleton :: OptimizeFlag ->
+ (forall g .
+ (GArrow g (,) ()
+ ,GArrowCopy g (,) ()
+ ,GArrowDrop g (,) ()
+ ,GArrowSwap g (,) ()
+ ,GArrowLoop g (,) ()
+ ,GArrowInclusion g (,) () m) =>
+ g x y)
+ -> GArrowSkeleton m x y
+mkSkeleton DoOptimize = \g -> (beautify . optimize) g
+mkSkeleton NoOptimize = \g -> g
+
+
+
+--
+-- | Performs some very simple-minded optimizations on a
+-- boxes-and-wires diagram. Preserves equivalence up to the GArrow
+-- laws, but no guarantees about which optimizations actually happen.
+--
+optimize :: (GArrowSkeleton m) a b -> (GArrowSkeleton m) a b
+optimize = repeat (gasl2gas . optimizel . {- FIXME -} optimizel . gas2gasl)
+
+{-
+optimize x = let x' = optimize' x in if x == x' then x' else optimize x'
+ where
+ optimize' :: (GArrowSkeleton m) a b -> (GArrowSkeleton m) a b
+
+ -- Some optimizations fail due to misparenthesization; we default to
+ -- left-associativity and hope for the best
+ optimize' (GAS_comp f (GAS_comp g h) ) = GAS_comp (GAS_comp f g) h
+ optimize' (GAS_comp (GAS_comp f (GAS_comp g h)) k) = GAS_comp (GAS_comp (GAS_comp f g) h) k
+ optimize' (GAS_comp (GAS_comp GAS_unassoc (GAS_second g)) GAS_assoc) = GAS_second (GAS_second g)
+ optimize' (GAS_comp (GAS_comp (GAS_comp f GAS_unassoc) (GAS_second g)) GAS_assoc) = GAS_comp f (GAS_second (GAS_second g))
+
+ optimize' (GAS_comp (GAS_comp f g) h) = case optimize_pair g h of
+ Nothing -> GAS_comp (optimize' (GAS_comp f g)) h'
+ Just ret' -> GAS_comp f' ret'
+ where
+ f' = optimize' f
+ g' = optimize' g
+ h' = optimize' h
+ optimize' (GAS_comp f g ) = case optimize_pair f g of
+ Nothing -> GAS_comp f' g'
+ Just ret' -> ret'
+ where
+ f' = optimize' f
+ g' = optimize' g
+ optimize' (GAS_first GAS_id ) = GAS_id
+ optimize' (GAS_second GAS_id ) = GAS_id
+-- optimize' (GAS_first (GAS_comp f g)) = GAS_comp (GAS_first f) (GAS_first g)
+-- optimize' (GAS_second (GAS_comp f g)) = GAS_comp (GAS_second f) (GAS_second g)
+ optimize' (GAS_first f ) = GAS_first $ optimize' f
+ optimize' (GAS_second f ) = GAS_second $ optimize' f
+ optimize' (GAS_loopl GAS_id ) = GAS_id
+ optimize' (GAS_loopr GAS_id ) = GAS_id
+ optimize' (GAS_loopl f ) = GAS_loopl $ optimize' f
+ optimize' (GAS_loopr f ) = GAS_loopr $ optimize' f
+ optimize' x = x
+
+ optimize_pair :: (GArrowSkeleton m) a b -> (GArrowSkeleton m) b c -> Maybe ((GArrowSkeleton m) a c)
+
+ optimize_pair f GAS_drop = Just $ GAS_drop
+ optimize_pair GAS_id f = Just $ f
+ optimize_pair f GAS_id = Just $ f
+ optimize_pair GAS_uncancell GAS_cancell = Just $ GAS_id
+ optimize_pair GAS_uncancelr GAS_cancelr = Just $ GAS_id
+ optimize_pair GAS_cancell GAS_uncancell = Just $ GAS_id
+ optimize_pair GAS_cancelr GAS_uncancelr = Just $ GAS_id
+ optimize_pair GAS_uncancelr GAS_cancell = Just $ GAS_id
+ optimize_pair GAS_uncancell GAS_cancelr = Just $ GAS_id
+
+ -- first priority: eliminate GAS_first
+ optimize_pair (GAS_first f) GAS_cancelr = Just $ GAS_comp GAS_cancelr f
+ optimize_pair (GAS_second f) GAS_cancell = Just $ GAS_comp GAS_cancell f
+ optimize_pair GAS_uncancelr (GAS_first f) = Just $ GAS_comp f GAS_uncancelr
+ optimize_pair GAS_uncancell (GAS_second f) = Just $ GAS_comp f GAS_uncancell
+
+ -- second priority: push GAS_swap leftward
+ optimize_pair (GAS_second f) GAS_swap = Just $ GAS_comp GAS_swap (GAS_first f)
+ optimize_pair (GAS_first f) GAS_swap = Just $ GAS_comp GAS_swap (GAS_second f)
+ optimize_pair GAS_swap GAS_swap = Just $ GAS_id
+ optimize_pair GAS_swap GAS_cancell = Just $ GAS_cancelr
+ optimize_pair GAS_swap GAS_cancelr = Just $ GAS_cancell
+
+ optimize_pair GAS_assoc GAS_cancell = Just $ GAS_first GAS_cancell
+ optimize_pair GAS_unassoc GAS_cancelr = Just $ GAS_second GAS_cancelr
+ optimize_pair GAS_assoc (GAS_second GAS_cancell) = Just $ GAS_first GAS_cancelr
+ optimize_pair GAS_unassoc (GAS_first GAS_cancell) = Just $ GAS_cancell
+
+
+ -- FIXME: valid only for central morphisms
+ --optimize_pair (GAS_second f) (GAS_first g) = Just $ GAS_comp (GAS_first g) (GAS_second f)
+ optimize_pair (GAS_first g) (GAS_second f) = Just $ GAS_comp (GAS_second f) (GAS_first g)
+
+ optimize_pair _ _ = Nothing
+-}
+
+repeat :: Eq a => (a -> a) -> a -> a
+repeat f x = let x' = f x in
+ if x == x'
+ then x
+ else repeat f x'
+
+--
+-- | Recursively turns @(ga_first x >>> first y)@ into @(ga_first (x >>> y))@, likewise for ga_second.
+--
+beautify :: (GArrowSkeleton m) a b -> (GArrowSkeleton m) a b
+beautify = repeat beautify'
+ where
+ beautify' :: (GArrowSkeleton m) a b -> (GArrowSkeleton m) a b
+ beautify' (GAS_comp (GAS_comp f g) h) = beautify' $ GAS_comp f $ GAS_comp g h
+ beautify' (GAS_comp f (GAS_comp (GAS_comp g h) k)) = beautify' $ GAS_comp f $ GAS_comp g $ GAS_comp h k
+ beautify' (GAS_comp f (GAS_comp g h)) = case (beautify' f, beautify' g) of
+ (GAS_first f' , GAS_first g') -> beautify' $ GAS_comp (GAS_first (GAS_comp f' g')) h
+ (GAS_second f', GAS_second g') -> beautify' $ GAS_comp (GAS_second (GAS_comp f' g')) h
+ (f' , g' ) -> GAS_comp f' (beautify' (GAS_comp g h))
+ beautify' (GAS_comp f GAS_id) = f
+ beautify' (GAS_comp GAS_id f) = f
+ beautify' (GAS_comp f g) = case (beautify' f, beautify' g) of
+ (GAS_first f' , GAS_first g') -> GAS_first (GAS_comp f' g')
+ (GAS_second f', GAS_second g') -> GAS_second (GAS_comp f' g')
+ (f' , g' ) -> GAS_comp f' g'
+ beautify' (GAS_first f) = GAS_first $ beautify' f
+ beautify' (GAS_second f) = GAS_second $ beautify' f
+ beautify' (GAS_loopl f) = GAS_loopl $ beautify' f
+ beautify' (GAS_loopr f) = GAS_loopr $ beautify' f
+ beautify' q = q
+
+
+
+
+gas2gasl :: GArrowSkeleton m x y -> GArrowSkeletonL m x y
+gas2gasl (GAS_id ) = GASL_id
+gas2gasl (GAS_comp f g) = gaslcat (gas2gasl f) (gas2gasl g)
+gas2gasl (GAS_first f) = gasl_firstify $ gas2gasl f
+gas2gasl (GAS_second f) = gasl_secondify $ gas2gasl f
+gas2gasl (GAS_cancell ) = GASL_Y $ GASY_X $ GASX_cancell
+gas2gasl (GAS_cancelr ) = GASL_Y $ GASY_X $ GASX_cancelr
+gas2gasl (GAS_uncancell ) = GASL_Y $ GASY_X $ GASX_uncancell
+gas2gasl (GAS_uncancelr ) = GASL_Y $ GASY_X $ GASX_uncancelr
+gas2gasl (GAS_assoc ) = GASL_Y $ GASY_X $ GASX_assoc
+gas2gasl (GAS_unassoc ) = GASL_Y $ GASY_X $ GASX_unassoc
+gas2gasl (GAS_drop ) = GASL_Y $ GASY_X $ GASX_drop
+gas2gasl (GAS_copy ) = GASL_Y $ GASY_X $ GASX_copy
+gas2gasl (GAS_swap ) = GASL_Y $ GASY_X $ GASX_swap
+gas2gasl (GAS_loopl f) = GASL_Y $ GASY_X $ GASX_loopl $ gas2gasl f
+gas2gasl (GAS_loopr f) = GASL_Y $ GASY_X $ GASX_loopr $ gas2gasl f
+gas2gasl (GAS_misc m) = GASL_Y $ GASY_X $ GASX_misc m
+
+-- apply "first" to a GASL
+gasl_firstify :: GArrowSkeletonL m x y -> GArrowSkeletonL m (x,z) (y,z)
+gasl_firstify (GASL_id ) = GASL_id
+gasl_firstify (GASL_Y gy ) = GASL_Y $ GASY_first $ gy
+gasl_firstify (GASL_comp gxq gqy) = GASL_comp (GASY_first gxq) $ gasl_firstify gqy
+
+-- apply "second" to a GASL
+gasl_secondify :: GArrowSkeletonL m x y -> GArrowSkeletonL m (z,x) (z,y)
+gasl_secondify (GASL_id ) = GASL_id
+gasl_secondify (GASL_Y gy ) = GASL_Y $ GASY_second $ gy
+gasl_secondify (GASL_comp gxq gqy) = GASL_comp (GASY_second gxq) $ gasl_secondify gqy
+
+-- concatenates two GASL's
+gaslcat :: GArrowSkeletonL m x y -> GArrowSkeletonL m y z -> GArrowSkeletonL m x z
+gaslcat (GASL_id ) g' = g'
+gaslcat (GASL_Y gy ) g' = GASL_comp gy g'
+gaslcat (GASL_comp gxq gqy) g' = GASL_comp gxq (gaslcat gqy g')
+
+data GArrowSkeletonL m :: * -> * -> *
+ where
+ GASL_id :: GArrowSkeletonL m x x
+ GASL_Y :: GArrowSkeletonY m x y -> GArrowSkeletonL m x y
+ GASL_comp :: GArrowSkeletonY m x y -> GArrowSkeletonL m y z -> GArrowSkeletonL m x z
+
+data GArrowSkeletonY m :: * -> * -> *
+ where
+ GASY_X :: GArrowSkeletonX m x y -> GArrowSkeletonY m x y
+ GASY_first :: GArrowSkeletonY m x y -> GArrowSkeletonY m (x,z) (y,z)
+ GASY_second :: GArrowSkeletonY m x y -> GArrowSkeletonY m (z,x) (z,y)
+ GASY_atomicl :: GArrowSkeletonY m () x -> GArrowSkeletonY m y (x,y)
+ GASY_atomicr :: GArrowSkeletonY m () x -> GArrowSkeletonY m y (y,x)
+
+data GArrowSkeletonX m :: * -> * -> *
+ where
+ GASX_cancell :: GArrowSkeletonX m ((),x) x
+ GASX_cancelr :: GArrowSkeletonX m (x,()) x
+ GASX_uncancell :: GArrowSkeletonX m x ((),x)
+ GASX_uncancelr :: GArrowSkeletonX m x (x,())
+ GASX_assoc :: GArrowSkeletonX m ((x,y),z) (x,(y,z))
+ GASX_unassoc :: GArrowSkeletonX m (x,(y,z)) ((x,y),z)
+ GASX_drop :: GArrowSkeletonX m x ()
+ GASX_copy :: GArrowSkeletonX m x (x,x)
+ GASX_swap :: GArrowSkeletonX m (x,y) (y,x)
+ GASX_misc :: m x y -> GArrowSkeletonX m x y
+ GASX_loopl :: GArrowSkeletonL m (z,x) (z,y) -> GArrowSkeletonX m x y
+ GASX_loopr :: GArrowSkeletonL m (x,z) (y,z) -> GArrowSkeletonX m x y
+
+-- TO DO: gather "maximal chunks" of ga_first/ga_second
+gasl2gas :: GArrowSkeletonL m x y -> GArrowSkeleton m x y
+gasl2gas GASL_id = GAS_id
+gasl2gas (GASL_Y gy ) = gasy2gas gy
+gasl2gas (GASL_comp gy gl) = GAS_comp (gasy2gas gy) (gasl2gas gl)
+
+gasy2gas :: GArrowSkeletonY m x y -> GArrowSkeleton m x y
+gasy2gas (GASY_X gx) = gasx2gas gx
+gasy2gas (GASY_first gy) = GAS_first (gasy2gas gy)
+gasy2gas (GASY_second gy) = GAS_second (gasy2gas gy)
+gasy2gas (GASY_atomicl gy) = GAS_comp GAS_uncancell (GAS_first $ gasy2gas gy)
+gasy2gas (GASY_atomicr gy) = GAS_comp GAS_uncancelr (GAS_second $ gasy2gas gy)
+
+gasx2gas :: GArrowSkeletonX m x y -> GArrowSkeleton m x y
+gasx2gas (GASX_cancell) = GAS_cancell
+gasx2gas (GASX_cancelr) = GAS_cancelr
+gasx2gas (GASX_uncancell) = GAS_uncancell
+gasx2gas (GASX_uncancelr) = GAS_uncancelr
+gasx2gas (GASX_assoc) = GAS_assoc
+gasx2gas (GASX_unassoc) = GAS_unassoc
+gasx2gas (GASX_drop) = GAS_drop
+gasx2gas (GASX_copy) = GAS_copy
+gasx2gas (GASX_swap) = GAS_swap
+gasx2gas (GASX_misc m) = GAS_misc m
+gasx2gas (GASX_loopl gl) = GAS_loopl $ gasl2gas gl
+gasx2gas (GASX_loopr gl) = GAS_loopr $ gasl2gas gl
+
+
+
+optimizel :: GArrowSkeletonL m x y -> GArrowSkeletonL m x y
+--optimizel (GASL_comp (GASL_Y (GASY_X GAS_uncancelr)) (GASL_Y (GASY_X GASX_copy))) =
+-- (GASL_comp (GASL_Y (GASY_X GAS_uncancelr)) (GASL_Y (GASY_X GASX_copy)))
+optimizel (GASL_id ) = GASL_id
+optimizel (GASL_Y gy ) = GASL_Y $ optimizey gy
+optimizel (GASL_comp gy (GASL_comp gy' gl)) | Just x <- optpair gy gy' = optimizel $ gaslcat x gl
+optimizel (GASL_comp gy (GASL_Y gy')) | Just x <- optpair gy gy' = x
+optimizel (GASL_comp gy (GASL_comp gy' gl)) | pushright gy, not (pushright gy'), Just x <- swappair gy gy' = optimizel $ gaslcat x gl
+optimizel (GASL_comp gy (GASL_Y gy')) | pushright gy, not (pushright gy'), Just x <- swappair gy gy' = GASL_comp (optimizey gy) (GASL_Y gy')
+optimizel (GASL_comp gy gl) = GASL_comp (optimizey gy) (optimizel gl)
+
+--optimize' (GAS_loopl GAS_id ) = GAS_id
+--optimize' (GAS_loopr GAS_id ) = GAS_id
+--optimize_pair f GAS_drop = Just $ GAS_drop
+{-
+ optimize_pair (GAS_first f) GAS_cancelr = Just $ GAS_comp GAS_cancelr f
+ optimize_pair (GAS_second f) GAS_cancell = Just $ GAS_comp GAS_cancell f
+ optimize_pair GAS_uncancelr (GAS_first f) = Just $ GAS_comp f GAS_uncancelr
+ optimize_pair GAS_uncancell (GAS_second f) = Just $ GAS_comp f GAS_uncancell
+ optimize_pair (GAS_second f) GAS_swap = Just $ GAS_comp GAS_swap (GAS_first f)
+ optimize_pair (GAS_first f) GAS_swap = Just $ GAS_comp GAS_swap (GAS_second f)
+ optimize_pair GAS_swap GAS_swap = Just $ GAS_id
+ optimize_pair GAS_swap GAS_cancell = Just $ GAS_cancelr
+ optimize_pair GAS_swap GAS_cancelr = Just $ GAS_cancell
+ optimize_pair GAS_assoc GAS_cancell = Just $ GAS_first GAS_cancell
+ optimize_pair GAS_unassoc GAS_cancelr = Just $ GAS_second GAS_cancelr
+ optimize_pair GAS_assoc (GAS_second GAS_cancell) = Just $ GAS_first GAS_cancelr
+ optimize_pair GAS_unassoc (GAS_first GAS_cancell) = Just $ GAS_cancell
+-}
+
+optpair :: GArrowSkeletonY m x y -> GArrowSkeletonY m y z -> Maybe (GArrowSkeletonL m x z)
+
+optpair (GASY_atomicl g) (GASY_X GASX_cancelr) = Just $ GASL_Y g
+optpair (GASY_atomicr g) (GASY_X GASX_cancell) = Just $ GASL_Y g
+
+optpair (GASY_X GASX_uncancell) (GASY_X GASX_cancell) = Just $ GASL_id
+optpair (GASY_X GASX_uncancelr) (GASY_X GASX_cancelr) = Just $ GASL_id
+optpair (GASY_X GASX_cancell) (GASY_X GASX_uncancell) = Just $ GASL_id
+optpair (GASY_X GASX_cancelr) (GASY_X GASX_uncancelr) = Just $ GASL_id
+optpair (GASY_X GASX_uncancelr) (GASY_X GASX_cancell) = Just $ GASL_id
+optpair (GASY_X GASX_uncancell) (GASY_X GASX_cancelr) = Just $ GASL_id
+optpair (GASY_X GASX_assoc) (GASY_X GASX_cancell) = Just $ GASL_Y $ GASY_first $ GASY_X GASX_cancell
+optpair (GASY_X GASX_unassoc) (GASY_X GASX_cancelr) = Just $ GASL_Y $ GASY_second $ GASY_X GASX_cancelr
+optpair (GASY_second (GASY_X GASX_uncancelr)) (GASY_X GASX_unassoc ) = Just $ GASL_Y $ GASY_X GASX_uncancelr
+optpair (GASY_first (GASY_X GASX_uncancell)) (GASY_X GASX_assoc ) = Just $ GASL_Y $ GASY_X GASX_uncancell
+optpair (GASY_X GASX_uncancell) (GASY_X GASX_unassoc ) = Just $ GASL_Y $ GASY_first $ GASY_X GASX_uncancell
+optpair (GASY_X GASX_uncancelr) (GASY_X GASX_assoc ) = Just $ GASL_Y $ GASY_second $ GASY_X GASX_uncancelr
+optpair (GASY_first (GASY_X GASX_uncancelr)) (GASY_X GASX_assoc ) = Just $ GASL_Y $ GASY_second $ GASY_X GASX_uncancell
+optpair (GASY_second (GASY_X GASX_uncancell)) (GASY_X GASX_unassoc ) = Just $ GASL_Y $ GASY_first $ GASY_X GASX_uncancelr
+optpair (GASY_X GASX_assoc) (GASY_second (GASY_X GASX_cancelr)) = Just $ GASL_Y $ GASY_X $ GASX_cancelr
+optpair (GASY_X GASX_unassoc) (GASY_first (GASY_X GASX_cancell)) = Just $ GASL_Y $ GASY_X $ GASX_cancell
+optpair (GASY_first g) (GASY_X GASX_cancelr) = Just $ GASL_comp (GASY_X GASX_cancelr) $ GASL_Y $ g
+optpair (GASY_second g) (GASY_X GASX_cancell) = Just $ GASL_comp (GASY_X GASX_cancell) $ GASL_Y $ g
+optpair (GASY_X GASX_uncancelr) (GASY_first g) = Just $ GASL_comp g $ GASL_Y (GASY_X GASX_uncancelr)
+optpair (GASY_X GASX_uncancell) (GASY_second g) = Just $ GASL_comp g $ GASL_Y (GASY_X GASX_uncancell)
+
+-- swap with an {un}cancel{l,r} before/after it
+optpair (GASY_X GASX_uncancell) (GASY_X GASX_swap ) = Just $ GASL_Y $ GASY_X $ GASX_uncancelr
+optpair (GASY_X GASX_uncancelr) (GASY_X GASX_swap ) = Just $ GASL_Y $ GASY_X $ GASX_uncancell
+optpair (GASY_X GASX_swap) (GASY_X GASX_cancell) = Just $ GASL_Y $ GASY_X $ GASX_cancelr
+optpair (GASY_X GASX_swap) (GASY_X GASX_cancelr) = Just $ GASL_Y $ GASY_X $ GASX_cancell
+
+{-
+optpair (GASY_X GASX_uncancelr) (GASY_X (GASX_loopl gl)) =
+ Just $ GASL_Y $ (GASY_X $ GASX_loopl $ GASL_comp (GASY_second $ GASY_X GASX_uncancelr) gl)
+optpair (GASY_X GASX_uncancell) (GASY_X (GASX_loopl gl)) =
+ Just $ GASL_Y $ (GASY_X $ GASX_loopl $ GASL_comp (GASY_second $ GASY_X GASX_uncancell) gl)
+optpair (GASY_X GASX_uncancelr) (GASY_X (GASX_loopr gl)) =
+ Just $ GASL_Y $ (GASY_X $ GASX_loopr $ GASL_comp (GASY_first $ GASY_X GASX_uncancelr) gl)
+optpair (GASY_X GASX_uncancell) (GASY_X (GASX_loopr gl)) =
+ Just $ GASL_Y $ (GASY_X $ GASX_loopr $ GASL_comp (GASY_first $ GASY_X GASX_uncancell) gl)
+-}
+optpair q (GASY_X (GASX_loopl gl)) | pushin q = Just $ GASL_Y $ (GASY_X $ GASX_loopl $ GASL_comp (GASY_second $ q) gl)
+optpair q (GASY_X (GASX_loopr gl)) | pushin q = Just $ GASL_Y $ (GASY_X $ GASX_loopr $ GASL_comp (GASY_first $ q) gl)
+
+optpair (GASY_first gy1) (GASY_second gy2) | pushleft gy2, not (pushleft gy1)
+ = Just $ GASL_comp (GASY_second gy2) $ GASL_Y $ GASY_first gy1
+optpair (GASY_second gy1) (GASY_first gy2) | pushleft gy2, not (pushleft gy1)
+ = Just $ GASL_comp (GASY_first gy2) $ GASL_Y $ GASY_second gy1
+
+optpair (GASY_first gy1) (GASY_first gy2) = liftM gasl_firstify $ optpair gy1 gy2
+optpair (GASY_second gy1) (GASY_second gy2) = liftM gasl_secondify $ optpair gy1 gy2
+optpair _ _ = Nothing
+
+swappair :: GArrowSkeletonY m x y -> GArrowSkeletonY m y z -> Maybe (GArrowSkeletonL m x z)
+
+swappair q (GASY_atomicl g) = Just $ GASL_comp (GASY_atomicl g) $ GASL_Y $ GASY_second q
+swappair q (GASY_atomicr g) = Just $ GASL_comp (GASY_atomicr g) $ GASL_Y $ GASY_first q
+
+swappair (GASY_first gy1) (GASY_second gy2) = Just $ GASL_comp (GASY_second gy2) (GASL_Y $ GASY_first gy1)
+swappair (GASY_second gy1) (GASY_first gy2) = Just $ GASL_comp (GASY_first gy2) (GASL_Y $ GASY_second gy1)
+swappair (GASY_first gy1) (GASY_X GASX_unassoc) = Just $ GASL_comp(GASY_X GASX_unassoc) (GASL_Y $ GASY_first (GASY_first gy1))
+swappair (GASY_second gy1) (GASY_X GASX_assoc ) = Just $ GASL_comp(GASY_X GASX_assoc ) (GASL_Y $ GASY_second (GASY_second gy1))
+swappair (GASY_X GASX_uncancelr) (GASY_first gy) = Just $ GASL_comp gy (GASL_Y $ GASY_X $ GASX_uncancelr)
+swappair (GASY_X GASX_uncancell) (GASY_second gy) = Just $ GASL_comp gy (GASL_Y $ GASY_X $ GASX_uncancell)
+swappair (GASY_first (GASY_second gy)) (GASY_X GASX_assoc ) = Just $ GASL_comp (GASY_X GASX_assoc ) $ GASL_Y (GASY_second (GASY_first gy))
+swappair (GASY_second (GASY_first gy)) (GASY_X GASX_unassoc ) = Just $ GASL_comp (GASY_X GASX_unassoc) $ GASL_Y (GASY_first (GASY_second gy))
+swappair (GASY_second (GASY_second gy)) (GASY_X GASX_unassoc ) = Just $ GASL_comp (GASY_X GASX_unassoc) $ GASL_Y (GASY_second gy)
+swappair (GASY_first (GASY_first gy)) (GASY_X GASX_assoc ) = Just $ GASL_comp (GASY_X GASX_assoc) $ GASL_Y (GASY_first gy)
+swappair (GASY_first gy) (GASY_X GASX_swap ) = Just $ GASL_comp (GASY_X GASX_swap) $ GASL_Y (GASY_second gy)
+swappair (GASY_second gy) (GASY_X GASX_swap ) = Just $ GASL_comp (GASY_X GASX_swap) $ GASL_Y (GASY_first gy)
+swappair gy (GASY_X (GASX_loopl gl)) = Just $ GASL_Y $ GASY_X $ GASX_loopl $ GASL_comp (GASY_second gy) gl
+swappair gy (GASY_X (GASX_loopr gl)) = Just $ GASL_Y $ GASY_X $ GASX_loopr $ GASL_comp (GASY_first gy) gl
+
+swappair (GASY_first gy1) (GASY_first gy2) = liftM gasl_firstify $ swappair gy1 gy2
+swappair (GASY_second gy1) (GASY_second gy2) = liftM gasl_secondify $ swappair gy1 gy2
+swappair _ _ = Nothing
+
+-- pushright can only return True for central morphisms
+pushright :: GArrowSkeletonY m x y -> Bool
+pushright (GASY_first gy) = pushright gy
+pushright (GASY_second gy) = pushright gy
+pushright (GASY_atomicl _) = False
+pushright (GASY_atomicr _) = False
+pushright (GASY_X GASX_uncancell) = True
+pushright (GASY_X GASX_uncancelr) = True
+pushright (GASY_X _ ) = False
+
+-- says if we should push it into a loopl/r
+pushin :: GArrowSkeletonY m x y -> Bool
+pushin gy = pushright gy || pushin' gy
+ where
+ pushin' :: GArrowSkeletonY m a b -> Bool
+ pushin' (GASY_first gy) = pushin' gy
+ pushin' (GASY_second gy) = pushin' gy
+ pushin' (GASY_atomicl _) = False
+ pushin' (GASY_atomicr _) = False
+
+ -- not sure if these are a good idea
+ pushin' (GASY_X GASX_copy) = True
+ pushin' (GASY_X GASX_swap) = True
+
+ pushin' (GASY_X _ ) = False
+
+optimizey :: GArrowSkeletonY m x y -> GArrowSkeletonY m x y
+optimizey (GASY_X gx) = GASY_X $ optimizex gx
+optimizey (GASY_first gy) = GASY_first (optimizey gy)
+optimizey (GASY_second gy) = GASY_second (optimizey gy)
+optimizey (GASY_atomicl gy) = GASY_atomicl $ optimizey gy
+optimizey (GASY_atomicr gy) = GASY_atomicr $ optimizey gy
+
+optimizex :: GArrowSkeletonX m x y -> GArrowSkeletonX m x y
+optimizex (GASX_cancell) = GASX_cancell
+optimizex (GASX_cancelr) = GASX_cancelr
+optimizex (GASX_uncancell) = GASX_uncancell
+optimizex (GASX_uncancelr) = GASX_uncancelr
+optimizex (GASX_assoc) = GASX_assoc
+optimizex (GASX_unassoc) = GASX_unassoc
+optimizex (GASX_drop) = GASX_drop
+optimizex (GASX_copy) = GASX_copy
+optimizex (GASX_swap) = GASX_swap
+optimizex (GASX_misc m) = GASX_misc m
+optimizex (GASX_loopl (GASL_comp (GASY_first gy) gl))| pushleft gy = GASX_loopl $ gaslcat gl (GASL_Y $ GASY_first gy)
+optimizex (GASX_loopr (GASL_comp (GASY_second gy) gl))| pushleft gy = GASX_loopr $ gaslcat gl (GASL_Y $ GASY_second gy)
+optimizex (GASX_loopl gl) = GASX_loopl $ optimizel gl
+optimizex (GASX_loopr gl) = GASX_loopr $ optimizel gl
+
+pushleft :: GArrowSkeletonY m x y -> Bool
+pushleft (GASY_first gy) = pushleft gy
+pushleft (GASY_second gy) = pushleft gy
+pushleft (GASY_atomicl _) = False
+pushleft (GASY_atomicr _) = False
+pushleft (GASY_X GASX_cancell) = True
+pushleft (GASY_X GASX_cancelr) = True
+pushleft (GASY_X _ ) = False
-{-# OPTIONS_GHC -XModalTypes -XMultiParamTypeClasses -ddump-types -XNoMonoPatBinds #-}
-module GArrowTikZ
+{-# LANGUAGE RankNTypes, MultiParamTypeClasses, GADTs, FlexibleContexts, FlexibleInstances, TypeOperators #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GArrowTikZ
+-- Copyright : none
+-- License : public domain
+--
+-- Maintainer : Adam Megacz <megacz@acm.org>
+-- Stability : experimental
+--
+-- | Renders a @GArrowSkeleton@ using TikZ; the result is LaTeX code.
+-- You must have lp_solve installed in order for this to work.
+--
+
+module GArrowTikZ (tikz,Opaque(..),toTikZ,tikz_header,tikz_footer,skelify',skelify'')
where
-import Prelude hiding ( id, (.) )
+import System.Process
+import Prelude hiding ( id, (.), lookup )
+import Control.Category
+import Control.Monad.State
+import Control.GArrow
+import Data.List hiding (lookup, insert)
+import Data.Map hiding (map, (!))
+import Data.Maybe (catMaybes)
+import Unify
+import GArrowSkeleton
+import GArrowPortShape
+import GHC.HetMet.Private
+
+skelify' :: (forall g . (GArrowCopy g (,) (), GArrowDrop g (,) (), GArrowSwap g (,) (), GArrowLoop g (,) ()) => g x y) ->
+ GArrowSkeleton Opaque x y
+skelify' = \g -> g
+
+skelify'' :: GArrowSkeleton Opaque x y -> GArrowSkeleton Opaque x y
+skelify'' = \g -> g
+
+------------------------------------------------------------------------------
+-- Tracks
--
--- Render a fully-polymorphic GArrow term as a boxes-and-wires diagram using TikZ
+-- Figuring out the x-coordinates of the boxes is easy, but we'll need
+-- to use lp_solve to get a nice layout for the y-coordinates of the
+-- wires. A @Track@ is basically just a y-axis position for one of
+-- the horizontal wires in the boxes-and-wires diagram; we will assign
+-- a unique Int to each visual element that has a y-coordinate, then
+-- generate a big pile of constraints on these y-coordinates and have
+-- lp_solve find a solution.
+--
+type TrackIdentifier = Int
+
+data Tracks = T TrackIdentifier
+ | TU TrackIdentifier -- a track known to be of unit type
+ | TT Tracks Tracks
+
+instance Show Tracks where
+ show (T ti ) = "(T "++show ti++")"
+ show (TU ti ) = "(TU "++show ti++")"
+ show (TT t1 t2) = "(TT "++show t1++" "++show t2++")"
+
--
+-- | TrackPositions maps TrackIdentifiers to actual y-axis positions;
+-- this is what lp_solve gives us
+--
+type TrackPositions = TrackIdentifier -> Float
+
+(!) :: TrackPositions -> TrackIdentifier -> Float
+tp ! ti = tp ti
+
+-- | get the uppermost TrackIdentifier in a Tracks
+uppermost (T x) = x
+uppermost (TU x) = x
+uppermost (TT x y) = uppermost x
+
+-- | get the lowermost TrackIdentifier in a Tracks
+lowermost (T x) = x
+lowermost (TU x) = x
+lowermost (TT x y) = lowermost y
+
+
+class ToDiagram g where
+ toDiagram :: GArrowPortShape g () x y -> ConstraintM Diagram
+
+instance (Detect m, ToDiagram m) => ToDiagram (GArrowSkeleton m) where
+ toDiagram s = mkdiag s
+
+data Opaque x y where
+ MkOpaque :: String -> DetectM (GArrowPortShape Opaque UVar x y) -> Opaque x y
+
+instance Detect Opaque where
+ detect' (MkOpaque _ dm) = dm
+
+instance ToDiagram Opaque where
+ toDiagram (GASPortPassthrough inp outp (MkOpaque s _)) =
+ do { (top, x ,bot) <- alloc inp
+ ; (_, y ,_) <- alloc outp
+ --; constrainEq x y
+ ; simpleDiag'' s top x y bot [] "black" }
+ toDiagram q = mkdiag q
+
+-- do (top, x ,bot) <- alloc inp
+-- simpleDiag' s top x x bot [(x,x)] "gray!50"
+
+
+------------------------------------------------------------------------------
+-- Diagrams
+
+-- | A Diagram is the visual representation of a GArrowSkeleton
+data Diagram
+ = DiagramComp Diagram Diagram
+ | DiagramBox Float TrackIdentifier Tracks BoxRenderer Tracks TrackIdentifier
+ | DiagramBypassTop Tracks Diagram
+ | DiagramBypassBot Diagram Tracks
+ | DiagramLoopTop Tracks Diagram
+ | DiagramLoopBot Diagram Tracks
+
+-- | get the output tracks of a diagram
+getOut :: Diagram -> Tracks
+getOut (DiagramComp f g) = getOut g
+getOut (DiagramBox wid ptop pin q pout pbot) = pout
+getOut (DiagramBypassTop p f) = TT p (getOut f)
+getOut (DiagramBypassBot f p) = TT (getOut f) p
+getOut (DiagramLoopTop t d) = case getOut d of { TT z y -> y ; _ -> error "DiagramLoopTop: mismatch" }
+getOut (DiagramLoopBot d t) = case getOut d of { TT y z -> y ; _ -> error "DiagramLoopBot: mismatch" }
+
+-- | get the input tracks of a diagram
+getIn :: Diagram -> Tracks
+getIn (DiagramComp f g) = getIn f
+getIn (DiagramBox wid ptop pin q pout pbot) = pin
+getIn (DiagramBypassTop p f) = TT p (getIn f)
+getIn (DiagramBypassBot f p) = TT (getIn f) p
+getIn (DiagramLoopTop t d) = case getIn d of { TT z x -> x ; _ -> error "DiagramLoopTop: mismatch" }
+getIn (DiagramLoopBot d t) = case getIn d of { TT x z -> x ; _ -> error "DiagramLoopBot: mismatch" }
+
+-- | A BoxRenderer is just a routine that, given the dimensions of a
+-- boxes-and-wires box element, knows how to spit out a bunch of TikZ
+-- code that draws it
+type BoxRenderer =
+ TrackPositions -> -- resolves the TrackIdentifiers to actual y-coordinates
+ Float -> -- x1
+ Float -> -- y1
+ Float -> -- x2
+ Float -> -- y2
+ String -- TikZ code
+noRender :: BoxRenderer
+noRender _ _ _ _ _ = ""
+
+
+
+
+------------------------------------------------------------------------------
+-- Constraints
+
+-- | a constraint (to be dealt with by lp_solve) relates two track identifiers
+data Constraint = C TrackIdentifier Ordering TrackIdentifier {- plus -} Float
+ | EqualSpace TrackIdentifier TrackIdentifier TrackIdentifier TrackIdentifier
+
+-- instance Show Constraint where
+-- show (C t1 LT t2 k s) = "x"++(show t1)++" = x"++(show t2)++" + "++(show k) ++ ";\n"
+-- show (C t1 GT t2 k s) = "x"++(show t1)++" = x"++(show t2)++" + "++(show k) ++ ";\n"
+-- show (C t1 EQ t2 k s) = "x"++(show t1)++" = x"++(show t2)++" + "++(show k) ++ ";\n"
+
+instance Show Constraint where
+ show (C t1 LT t2 k) = "x"++(show t1)++" <= x"++(show t2)++" + "++(show k) ++ ";\n"
+ show (C t1 GT t2 k) = "x"++(show t1)++" >= x"++(show t2)++" + "++(show k) ++ ";\n"
+ show (C t1 EQ t2 k) = "x"++(show t1)++" = x"++(show t2)++" + "++(show k) ++ ";\n"
+ show (EqualSpace t1a t1b t2a t2b) = "x"++(show t1a)++" = x"++(show t1b)++
+ " + x"++(show t2a)++" - x"++(show t2b)++ ";\n"
+
+-- | a monad to accumulate constraints and track the largest TrackIdentifier allocated
+type ConstraintM a = State (TrackIdentifier,[Constraint]) a
+
+-- | pull the constraints out of the monad
+getConstraints :: ConstraintM [Constraint]
+getConstraints = do { (_,c) <- get ; return c }
+
+-- | add a constraint
+constrain :: TrackIdentifier -> Ordering -> TrackIdentifier {- plus -} -> Float -> ConstraintM ()
+constrain t1 ord t2 k = do { (t,c) <- get
+ ; put (t, (C t1 ord t2 k):c)
+ ; return ()
+ }
+
+constrainEqualSpace t1a t1b t2a t2b = do { (t,c) <- get
+ ; put (t, (EqualSpace t1a t1b t2a t2b):c)
+ ; return ()
+ }
+
+-- | simple form for equality constraints
+constrainEq (TT t1a t1b) (TT t2a t2b) = do { constrainEq t1a t2a ; constrainEq t1b t2b ; return () }
+constrainEq (T t1 ) (T t2 ) = constrain t1 EQ t2 0
+constrainEq (TU t1 ) (TU t2 ) = constrain t1 EQ t2 0
+constrainEq (TU t1 ) (T t2 ) = constrain t1 EQ t2 0
+constrainEq (T t1 ) (TU t2 ) = constrain t1 EQ t2 0
+constrainEq t1 t2 = error $ "constrainEq mismatch: " ++ show t1 ++ " and " ++ show t2
+
+-- | allocate a TrackIdentifier
+alloc1 :: ConstraintM Tracks
+alloc1 = do { (t,c) <- get
+ ; put (t+1,c)
+ ; return (T t)
+ }
+
+mkdiag :: ToDiagram m => GArrowPortShape m () a b -> ConstraintM Diagram
+mkdiag (GASPortPassthrough inp outp m) = toDiagram (GASPortPassthrough inp outp m)
+mkdiag (GASPortShapeWrapper inp outp x) = mkdiag' x
+ where
+ mkdiag' :: ToDiagram m => GArrowSkeleton (GArrowPortShape m ()) a b -> ConstraintM Diagram
+
+ mkdiag' (GAS_comp f g) = do { f' <- mkdiag' f; g' <- mkdiag' g
+ ; constrainEq (getOut f') (getIn g') ; return $ DiagramComp f' g' }
+ mkdiag' (GAS_first f) = do { (top,(TT _ x),bot) <- alloc inp; f' <- mkdiag' f ; constrainBot f' 1 (uppermost x)
+ ; return $ DiagramBypassBot f' x }
+ mkdiag' (GAS_second f) = do { (top,(TT x _),bot) <- alloc inp; f' <- mkdiag' f ; constrainTop (lowermost x) 1 f'
+ ; return $ DiagramBypassTop x f' }
+ mkdiag' (GAS_id ) = do { (top, x ,bot) <- alloc inp ; simpleDiag' "id" top x x bot [(x,x)] "gray!50" }
+ mkdiag' GAS_cancell = do { (top,(TT x y),bot) <- alloc inp
+ ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "cancell" ++
+ drawWires tp x1 y x2 y "black" ++
+ drawLine x1 (tp!lowermost x) ((x1+x2)/2) (tp!uppermost y) "gray!50" "dashed"
+ ; return $ DiagramBox 2.4 top (TT x y) r y bot }
+ mkdiag' GAS_cancelr = do { (top,(TT x y),bot) <- alloc inp
+ ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "cancelr" ++
+ drawWires tp x1 x x2 x "black" ++
+ drawLine x1 (tp!uppermost y) ((x1+x2)/2) (tp!lowermost x) "gray!50" "dashed"
+ ; return $ DiagramBox 2.4 top (TT x y) r x bot }
+ mkdiag' GAS_uncancell = do { (top,(TT x y),bot) <- alloc outp
+ ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "uncancell" ++
+ drawWires tp x1 y x2 y "black" ++
+ drawLine ((x1+x2)/2) (tp!uppermost y) x2 (tp!lowermost x) "gray!50" "dashed"
+ ; return $ DiagramBox 2.8 top y r (TT x y) bot }
+ mkdiag' GAS_uncancelr = do { (top,(TT x y),bot) <- alloc outp
+ ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "uncancelr" ++
+ drawWires tp x1 x x2 x "black" ++
+ drawLine ((x1+x2)/2) (tp!lowermost x) x2 (tp!uppermost y) "gray!50" "dashed"
+ ; return $ DiagramBox 2.8 top x r (TT x y) bot }
+ mkdiag' GAS_drop = do { (top, x ,bot) <- alloc inp
+ ; (_, y ,_) <- alloc outp
+ ; constrainEq x y
+ ; simpleDiag "drop" top x y bot [] }
+ mkdiag' GAS_copy = do { (top,(TT y z),bot) <- alloc outp
+ ; (_ , x ,_) <- alloc inp
+ ; constrainEqualSpace (lowermost y) (uppermost x) (lowermost x) (uppermost z)
+ ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "copy" ++
+ drawWires tp x1 x ((x1+x2)/2) x "black" ++
+ drawWires tp ((x1+x2)/2) x x2 y "black" ++
+ drawWires tp ((x1+x2)/2) x x2 z "black"
+ ; return $ DiagramBox defaultWidth top x r (TT y z) bot
+ }
+ mkdiag' GAS_swap = do { (top,(TT x y),bot) <- alloc inp
+ ; (top,(TT x' y'),bot) <- alloc outp
+ ; constrainEq (T (lowermost x)) (T (lowermost x'))
+ ; constrainEq (T (uppermost y)) (T (uppermost y'))
+ ; simpleDiag' "swap" top (TT x y) (TT x' y') bot [(x,y'),(y,x')] "gray!50" }
+ mkdiag' GAS_assoc =
+ do { (top,(TT (TT x y) z),bot) <- alloc inp
+ ; let r tp x1 y1 x2 y2
+ = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "assoc" ++
+ drawLine x1 y1 x2 y1 "gray!50" "-" ++
+ drawLine x1 y2 x2 y2 "gray!50" "-" ++
+ drawLine x1 y1 x1 ((tp ! uppermost x) - 0.5) "gray!50" "-"++
+ drawLine x1 ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
+ drawLine (x1+0.2) ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
+ drawLine (x1+0.2) ((tp ! lowermost y) + 0.5) x1 ((tp ! lowermost y) + 0.5) "gray!50" "-"++
+ drawLine x1 ((tp ! lowermost y) + 0.5) x1 y2 "gray!50" "-"++
+ drawLine x2 y2 x2 ((tp ! lowermost z) + 0.5) "gray!50" "-"++
+ drawLine x2 ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
+ drawLine (x2-0.2) ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
+ drawLine (x2-0.2) ((tp ! uppermost y) - 0.5) x2 ((tp ! uppermost y) - 0.5) "gray!50" "-"++
+ drawLine x2 ((tp ! uppermost y) - 0.5) x2 y1 "gray!50" "-"++
+ drawWires tp x1 x x2 x "black" ++
+ drawWires tp x1 y x2 y "black" ++
+ drawWires tp x1 z x2 z "black"
+ ; let pin = (TT (TT x y) z)
+ ; let pout = (TT x (TT y z))
+ ; return $ if draw_assoc then DiagramBox defaultWidth top pin r pout bot else DiagramBox 0 top pin noRender pout bot
+ }
+ mkdiag' GAS_unassoc =
+ do { (top,(TT x (TT y z)),bot) <- alloc inp
+ ; let r tp x1 y1 x2 y2
+ = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "unassoc" ++
+ drawLine x1 y1 x2 y1 "gray!50" "-" ++
+ drawLine x1 y2 x2 y2 "gray!50" "-" ++
+ drawLine x2 y1 x2 ((tp ! uppermost x) - 0.5) "gray!50" "-"++
+ drawLine x2 ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
+ drawLine (x2-0.2) ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
+ drawLine (x2-0.2) ((tp ! lowermost y) + 0.5) x2 ((tp ! lowermost y) + 0.5) "gray!50" "-"++
+ drawLine x2 ((tp ! lowermost y) + 0.5) x2 y2 "gray!50" "-"++
+ drawLine x1 y2 x1 ((tp ! lowermost z) + 0.5) "gray!50" "-"++
+ drawLine x1 ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
+ drawLine (x1+0.2) ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
+ drawLine (x1+0.2) ((tp ! uppermost y) - 0.5) x1 ((tp ! uppermost y) - 0.5) "gray!50" "-"++
+ drawLine x1 ((tp ! uppermost y) - 0.5) x1 y1 "gray!50" "-"++
+ drawWires tp x1 x x2 x "black" ++
+ drawWires tp x1 y x2 y "black" ++
+ drawWires tp x1 z x2 z "black"
+ ; let pin = (TT x (TT y z))
+ ; let pout = (TT (TT x y) z)
+ ; return $ if draw_assoc then DiagramBox defaultWidth top pin r pout bot else DiagramBox 0 top pin noRender pout bot
+ }
+ mkdiag' (GAS_loopl f) = do { f' <- mkdiag' f
+ ; l <- allocLoop (case (getIn f') of (TT z _) -> z ; _ -> error "GAS_loopl: mismatch")
+ ; constrainTop (lowermost l) loopgap f'
+ ; return $ DiagramLoopTop l f' }
+ mkdiag' (GAS_loopr f) = do { f' <- mkdiag' f
+ ; l <- allocLoop (case (getIn f') of (TT _ z) -> z ; _ -> error "GAS_loopr: mismatch")
+ ; constrainBot f' loopgap (uppermost l)
+ ; return $ DiagramLoopBot f' l }
+ mkdiag' (GAS_misc f ) = mkdiag f
+
+defaultWidth = 2
+
+diagramBox :: TrackIdentifier -> Tracks -> BoxRenderer -> Tracks -> TrackIdentifier -> ConstraintM Diagram
+diagramBox ptop pin r pout pbot = do { constrain ptop LT (uppermost pin) (-1)
+ ; constrain pbot GT (lowermost pin) 1
+ ; constrain ptop LT (uppermost pout) (-1)
+ ; constrain pbot GT (lowermost pout) 1
+ ; constrain ptop LT pbot (-1)
+ ; return $ DiagramBox defaultWidth ptop pin r pout pbot
+ }
+simpleDiag text ptop pin pout pbot conn = simpleDiag' text ptop pin pout pbot conn "black"
+simpleDiag' text ptop pin pout pbot conn color = diagramBox ptop pin defren pout pbot
+ where
+ defren tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 color text ++
+ concat (map (\(x,y) -> drawWires tp x1 x x2 y "black") conn)
+ -- ++ wires (x-1) p1 x "green"
+ -- ++ wires (x+w) p2 (x+w+1) "red"
+simpleDiag'' text ptop pin pout pbot conn color = diagramBox ptop pin defren pout pbot
+ where
+ defren tp x1 y1 x2 y2 = drawBoxC x1 y1 x2 y2 color text ++
+ concat (map (\(x,y) -> drawWires tp x1 x x2 y "black") conn)
+ -- ++ wires (x-1) p1 x "green"
+ -- ++ wires (x+w) p2 (x+w+1) "red"
+
+draw_assoc = False
+draw_first_second = False
+--draw_assoc = True
+--draw_first_second = True
+
+-- constrain that Ports is at least Int units above the topmost portion of Diagram
+constrainTop :: TrackIdentifier -> Float -> Diagram -> ConstraintM ()
+constrainTop v i (DiagramComp d1 d2) = do { constrainTop v i d1 ; constrainTop v i d2 ; return () }
+constrainTop v i (DiagramBypassTop p d) = constrain v LT (uppermost p) (-1 * i)
+constrainTop v i (DiagramBypassBot d p) = constrainTop v (i+1) d
+constrainTop v i (DiagramBox wid ptop pin r pout pbot) = constrain v LT ptop (-1 * i)
+constrainTop v i (DiagramLoopTop p d) = constrain v LT (uppermost p) (-1 * i)
+constrainTop v i (DiagramLoopBot d p) = constrainTop v (i+1) d
+
+-- constrain that Ports is at least Int units below the bottommost portion of Diagram
+constrainBot :: Diagram -> Float -> TrackIdentifier -> ConstraintM ()
+constrainBot (DiagramComp d1 d2) i v = do { constrainBot d1 i v ; constrainBot d2 i v ; return () }
+constrainBot (DiagramBypassTop p d) i v = constrainBot d (i+1) v
+constrainBot (DiagramBypassBot d p) i v = constrain v GT (lowermost p) 2
+constrainBot (DiagramBox wid ptop pin r pout pbot) i v = constrain v GT pbot i
+constrainBot (DiagramLoopTop p d) i v = constrainBot d (i+1) v
+constrainBot (DiagramLoopBot d p) i v = constrain v GT (lowermost p) 2
+
+-- | The width of a box is easy to calculate
+width :: TrackPositions -> Diagram -> Float
+width m (DiagramComp d1 d2) = (width m d1) + 1 + (width m d2)
+width m (DiagramBox wid ptop pin x pout pbot) = wid
+width m (DiagramBypassTop p d) = (width m d) + (if draw_first_second then 2 else 0)
+width m (DiagramBypassBot d p) = (width m d) + (if draw_first_second then 2 else 0)
+width m (DiagramLoopTop p d) = (width m d) + 2 + 2 * (loopgap + (m ! lowermost p) - (m ! uppermost p))
+width m (DiagramLoopBot d p) = (width m d) + 2 + 2 * (loopgap + (m ! lowermost p) - (m ! uppermost p))
+
+drawWires :: TrackPositions -> Float -> Tracks -> Float -> Tracks -> String -> String
+drawWires tp x1 (TT a b) x2 (TT a' b') color = drawWires tp x1 a x2 a' color ++ drawWires tp x1 b x2 b' color
+drawWires tp x1 (T a) x2 (T a') color = drawLine x1 (tp!a) x2 (tp!a') color "-"
+drawWires tp x1 (TU a) x2 (TU a') color = drawLine x1 (tp!a) x2 (tp!a') "gray!50" "dashed"
+drawWires tp _ _ _ _ _ = error "drawwires fail"
+
+wirecos :: TrackPositions -> Tracks -> [(Float,Bool)]
+wirecos tp (TT a b) = wirecos tp a ++ wirecos tp b
+wirecos tp (T a) = [(tp!a,True)]
+wirecos tp (TU a) = [(tp!a,False)]
+
+wire90 :: Float -> Float -> (Float,Float,Bool) -> String
+wire90 x y (y1,y2,b) = drawLine' [(x,y1),(x',y1),(x',y2),(x,y2)] color (style++",rounded corners")
+ where
+ color = if b then "black" else "gray!50"
+ style = if b then "-" else "dashed"
+ x' = x - (y - y1) - loopgap
+
+wire90' x y (y1,y2,b) = drawLine' [(x,y1),(x',y1),(x',y2),(x,y2)] color (style++",rounded corners")
+ where
+ color = if b then "black" else "gray!50"
+ style = if b then "-" else "dashed"
+ x' = x + (y - y1) + loopgap
+
+tikZ :: TrackPositions ->
+ Diagram ->
+ Float -> -- horizontal position
+ String
+tikZ m = tikZ'
+ where
+ tikZ' d@(DiagramComp d1 d2) x = tikZ' d1 x
+ ++ wires' (x+width m d1) (getOut d1) (x+width m d1+0.5) "black" "->"
+ ++ wires' (x+width m d1+0.5) (getOut d1) (x+width m d1+1) "black" "-"
+ ++ tikZ' d2 (x + width m d1 + 1)
+ tikZ' d'@(DiagramBypassTop p d) x = if not draw_first_second
+ then drawWires m x p (x+width m d) p "black" ++ tikZ' d x
+ else
+ let top = getTop d' in
+ let bot = getBot d' in
+ drawBox x top (x+width m d') bot "gray!50" "second"
+ ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
+ ++ tikZ' d (x+1)
+ ++ drawWires m (x+1+width m d) (getOut d) (x+1+width m d+1) (getOut d) "black"
+ ++ drawWires m x p (x+1+width m d+1) p "black"
+ tikZ' d'@(DiagramBypassBot d p) x = if not draw_first_second
+ then drawWires m x p (x+width m d) p "black" ++ tikZ' d x
+ else
+ let top = getTop d' in
+ let bot = getBot d' in
+ drawBox x top (x+width m d') bot "gray!50" "first"
+ ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
+ ++ tikZ' d (x+1)
+ ++ drawWires m (x+1+width m d) (getOut d) (x+1+width m d+1) (getOut d) "black"
+ ++ drawWires m x p (x+1+width m d+1) p "black"
+ tikZ' d'@(DiagramLoopTop p d) x = let top = getTop d' in
+ let bot = getBot d' in
+ let gap = loopgap + (m ! lowermost p) - (m ! uppermost p) in
+ drawBox x top (x+width m d') bot "gray!50" "loopl"
+ ++ tikZ' d (x+1+gap)
+ ++ drawWires m (x+1+gap) p (x+1+gap+width m d) p "black"
+ ++ let p' = case getIn d of TT z _ -> z ; _ -> error "DiagramLoopTop: mismatch"
+ pzip = map (\((y,b),(y',_)) -> (y,y',b)) $ zip (wirecos m p) (reverse $ wirecos m p')
+ in concatMap (wire90 (x+1+gap) (m ! lowermost p)) pzip
+ ++ let p' = case getOut d of TT z _ -> z ; _ -> error "DiagramLoopTop: mismatch"
+ pzip = map (\((y,b),(y',_)) -> (y,y',b)) $ zip (wirecos m p) (reverse $ wirecos m p')
+ in concatMap (wire90' (x+1+gap+width m d) (m ! lowermost p)) pzip
+ ++ let rest = case getIn d of TT _ z -> z ; _ -> error "DiagramLoopTop: mismatch"
+ in drawWires m x rest (x+1+gap) rest "black"
+ ++ let rest = case getOut d of TT _ z -> z ; _ -> error "DiagramLoopTop: mismatch"
+ in drawWires m (x+1+gap+width m d) rest (x+width m d') rest "black"
+ tikZ' d'@(DiagramLoopBot d p) x_ = error "not implemented"
+ tikZ' d@(DiagramBox wid ptop pin r pout pbot) x = r m x (m ! ptop) (x + width m d) (m ! pbot)
+
+ wires x1 t x2 c = wires' x1 t x2 c "-"
+
+ wires' :: Float -> Tracks -> Float -> String -> String -> String
+ wires' x1 (TT x y) x2 color st = wires' x1 x x2 color st ++ wires' x1 y x2 color st
+ wires' x1 (T v) x2 color st = drawLine x1 (m ! v) x2 (m ! v) color st -- ++ textc ((x1+x2) / 2) (m!v) (show v) "purple"
+ wires' x1 (TU v) x2 color st = drawLine x1 (m ! v) x2 (m ! v) "gray!50" "dashed"
+
+ getTop :: Diagram -> Float
+ getTop (DiagramComp d1 d2) = min (getTop d1) (getTop d2)
+ getTop (DiagramBox wid ptop _ _ _ _) = m ! ptop
+ getTop (DiagramBypassTop p d) = (m ! uppermost p) - 1
+ getTop (DiagramBypassBot d p) = getTop d - 1
+ getTop (DiagramLoopTop p d) = (m ! uppermost p) - 1
+ getTop (DiagramLoopBot d p) = getTop d - 1
+
+ getBot :: Diagram -> Float
+ getBot (DiagramComp d1 d2) = max (getBot d1) (getBot d2)
+ getBot (DiagramBox wid _ _ _ _ pbot) = m ! pbot
+ getBot (DiagramBypassTop p d) = getBot d + 1
+ getBot (DiagramBypassBot d p) = (m ! lowermost p) + 1
+ getBot (DiagramLoopTop p d) = getBot d + 1
+ getBot (DiagramLoopBot d p) = (m ! lowermost p) + 1
+
+-- allocates multiple tracks, adding constraints that they are at least one unit apart
+alloc :: PortShape a -> ConstraintM (TrackIdentifier,Tracks,TrackIdentifier)
+alloc shape = do { tracks <- alloc' shape
+ ; T ptop <- alloc1
+ ; T pbot <- alloc1
+ ; constrain ptop LT (uppermost tracks) (-1)
+ ; constrain pbot GT (lowermost tracks) 1
+ ; return (ptop,tracks,pbot)
+ }
+ where
+ alloc' :: PortShape a -> ConstraintM Tracks
+ alloc' PortUnit = do { T x <- alloc1 ; return (TU x) }
+ alloc' (PortFree _) = do { x <- alloc1 ; return x }
+ alloc' (PortTensor p1 p2) = do { x1 <- alloc' p1
+ ; x2 <- alloc' p2
+ ; constrain (lowermost x1) LT (uppermost x2) (-1)
+ ; return (TT x1 x2)
+ }
+
+-- allocates a second set of tracks identical to the first one but constrained only relative to each other (one unit apart)
+-- and upside-down
+allocLoop :: Tracks -> ConstraintM Tracks
+allocLoop (TU _) = do { T x <- alloc1 ; return (TU x) }
+allocLoop (T _) = do { x <- alloc1 ; return x }
+allocLoop (TT t1 t2) = do { x1 <- allocLoop t2
+ ; x2 <- allocLoop t1
+ ; constrain (lowermost x1) LT (uppermost x2) (-1)
+ ; return (TT x1 x2)
+ }
+
+do_lp_solve :: [Constraint] -> IO String
+do_lp_solve c = do { let stdin = "min: x1;\n" ++ (foldl (++) "" (map show c)) ++ "\n"
+-- ; putStrLn stdin
+ ; stdout <- readProcess "lp_solve" [] stdin
+ ; return stdout
+ }
+
+splitWs :: String -> [String]
+splitWs s = splitWs' "" s
+ where
+ splitWs' [] [] = []
+ splitWs' acc [] = [acc]
+ splitWs' [] (' ':k) = splitWs' [] k
+ splitWs' acc (' ':k) = acc:(splitWs' [] k)
+ splitWs' acc (x:k) = splitWs' (acc++[x]) k
+
+lp_solve_to_trackpos :: String -> TrackPositions
+lp_solve_to_trackpos s = toTrackPos $ map parse $ catMaybes $ map grab $ lines s
+ where
+ grab ('x':k) = Just k
+ grab _ = Nothing
+ parse :: String -> (Int,Float)
+ parse s = case splitWs s of
+ [a,b] -> (read a, read b)
+ _ -> error "parse: should not happen"
+ toTrackPos :: [(Int,Float)] -> TrackPositions
+ toTrackPos [] tr = 0 -- error $ "could not find track "++show tr
+ toTrackPos ((i,f):rest) tr = if (i==tr) then f else toTrackPos rest tr
+
+
+toTikZ :: (ToDiagram m, Detect m) => GArrowSkeleton m a b -> IO String
+toTikZ g =
+ let cm = do { let g' = detectShape g
+ ; g'' <- mkdiag g'
+ ; return g''
+ }
+ in do { let (_,constraints) = execState cm (0,[])
+ ; lps <- do_lp_solve $ constraints
+ ; let m = lp_solve_to_trackpos lps
+ ; let d = evalState cm (0,[])
+ ; let t = tikZ m d 1
+ ; return (t ++ drawWires m 0 (getIn d) 1 (getIn d) "black"
+ ++ drawWires m (width m d+1) (getOut d) (width m d+2) (getOut d) "black")
+ }
+
+tikz_header =
+ "\\documentclass{article}\n" ++
+ "\\usepackage[paperwidth=\\maxdimen,paperheight=\\maxdimen]{geometry}\n" ++
+ "\\usepackage{tikz}\n" ++
+ "\\usepackage{amsmath}\n" ++
+ "\\usepackage[tightpage,active]{preview}\n" ++
+ "\\begin{document}\n" ++
+ "\\setlength\\PreviewBorder{5pt}\n" ++
+ "\\begin{preview}\n" ++
+ "\\begin{tikzpicture}[every on chain/.style={join=by ->},yscale=-1]\n"
+
+tikz_footer =
+ "\\end{tikzpicture}\n" ++
+ "\\end{preview}\n" ++
+ "\\end{document}\n"
+
+tikz example =
+ do putStrLn tikz_header
+ tikz <- toTikZ example
+ putStrLn tikz
+ putStrLn tikz_footer
+
+-- Random TikZ routines
+textc x y text color =
+ "\\node[anchor=center,color="++color++"] at ("++show (x*xscale)++"cm,"++show (y*yscale)++"cm) "++
+ "{{\\tt{"++text++"}}};\n"
+
+drawBox x1 y1 x2 y2 color text =
+ "\\node[anchor=north west] at ("++show (x1*xscale)++"cm,"++show (y1*yscale)++"cm) "++
+ "{{\\tt{"++text++"}}};\n"
+ ++
+ "\\path[draw,color="++color++"]"++
+ " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
+ show (x2*xscale)++","++show (y2*yscale)++");\n"
+
+drawBoxC x1 y1 x2 y2 color text =
+ "\\node[anchor=center] at ("++show ((x1+x2)*xscale/2)++"cm,"++show ((y1+y2)*yscale/2)++"cm) "++
+ "{{\\tt{"++text++"}}};\n"
+ ++
+ "\\path[draw,color="++color++"]"++
+ " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
+ show (x2*xscale)++","++show (y2*yscale)++");\n"
+
+drawLine x1 y1 x2 y2 color style =
+ "\\path[draw,color="++color++","++style++"] "++
+ "("++show (x1*xscale)++","++show (y1*yscale)++") -- " ++
+ "("++show (x2*xscale)++","++show (y2*yscale)++");\n"
+
+drawLine' [] color style = ""
+drawLine' (xy1:xy) color style =
+ "\\path[draw,color="++color++","++style++"] "++
+ foldl (\x y -> x ++ " -- " ++ y) (f xy1) (map f xy)
+ ++ ";\n"
+ where
+ f = (\(x,y) -> "("++show (x*xscale)++","++show (y*yscale)++")")
+
+-- | x scaling factor for the entire diagram, since TikZ doesn't scale font sizes
+xscale = 1
+
+-- | y scaling factor for the entire diagram, since TikZ doesn't scale font sizes
+yscale = 1
-{-
-instance GArrow GArrowTikZ (,) where
- ga_id =
- ga_comp f g =
- ga_second f =
- ga_cancell f =
- ga_cancelr f =
- ga_uncancell f =
- ga_uncancelr f =
- ga_assoc f =
- ga_unassoc f =
-
-instance GArrowDrop GArrowTikZ (,) where
- ga_drop =
-
-instance GArrowCopy GArrowTikZ (,) where
- ga_copy =
-
-instance GArrowSwap GArrowTikZ (,) where
- ga_swap =
-
-instance GArrowLoop GArrowTikZ (,) where
- ga_loop =
-
-instance GArrowLiteral GArrowTikZ (,) where
- ga_literal =
--}
+-- | extra gap placed between loopback wires and the contents of the loop module
+loopgap = 1
\ No newline at end of file
where
import Data.Bits
import Data.Bool (not)
-import GHC.HetMet.CodeTypes hiding ((-))
-import GHC.HetMet.GArrow
+import Control.GArrow
+import GHC.HetMet.GuestLanguage hiding ( (-) )
import Control.Category
import Control.Arrow
import Prelude hiding ( id, (.) )
-{-# OPTIONS_GHC -XModalTypes -XMultiParamTypeClasses -ddump-types -XNoMonoPatBinds #-}
-module GArrowVerilog
-where
-import Prelude hiding ( id, (.) )
-
---
--- Please ignore this; I didn't manage to finish it
---
-
-
-{-
--- A verilog module is an SDoc (chunk of text) giving the module's
--- definition. The UniqueSupply avoids name clashes.
-data VerilogModule =
- VerilogModule
- [VerilogModule] -- dependencies
- String -> -- module name
- (Tree String -> -- input port names
- Tree String -> -- output port names
- SDoc) -- raw verilog code for the body
-
-
-instance Show VerilogModule where
- show VerilogModule dep name body =
- "module "++name++"(FIXME)"++(body FIXME FIXME)
-
-data VerilogWrappedType a =
- { vwt_rep :: String }
-
--- A "verilog garrow" from A to B is, concretely, the source code for a
--- verilog module having input ports of type A and output ports of type B;
--- the UniqueSupply lets us generate names.
-data GArrowVerilog a b =
- UniqueSupply ->
- VerilogWrappedType a ->
- VerilogWrappedType b ->
- GArrowVerilog SDoc
-
-instance GArrow GArrowVerilog (,) where
- ga_id = VerilogModule [] "ga_id" (\ inp outp -> zipTree ... "assign "++outp++" = "++inp)
- ga_comp f g = VerilogModule [] "ga_comp"
- ga_first :: g x y -> g (x ** z) (y ** z)
- ga_second f = ga_comp (ga_comp ga_swap (ga_first f)) ga_swap
- ga_cancell f = VerilogModule [] "ga_cancell" (\ [in1,in2] [outp] -> "assign "++outp++" = "++in2)
- ga_cancelr f = VerilogModule [] "ga_cancelr" (\ [in1,in2] [outp] -> "assign "++outp++" = "++in1)
- ga_uncancell f = VerilogModule [] "ga_cancelr" (\ [in1] [out1,out2] -> "assign "++out1++"=1'b0;\n assign"++out2++"="++in1)
- ga_uncancelr f = VerilogModule [] "ga_cancelr" (\ [in1] [out1,out2] -> "assign "++out2++"=1'b0;\n assign"++out1++"="++in1)
- ga_assoc f =
- ga_unassoc :: g (x**(y**z)) ((x**y)**z)
-
-instance GArrowDrop GArrowVerilog (,) where
- ga_drop =
-
-instance GArrowCopy GArrowVerilog (,) where
- ga_copy =
-
-instance GArrowSwap GArrowVerilog (,) where
- ga_swap =
-
-instance GArrowLoop GArrowVerilog (,) where
- ga_loop =
-
-instance GArrowLiteral GArrowVerilog (,) where
- ga_literal =
--}
+{-# LANGUAGE MultiParamTypeClasses, TypeOperators, FunctionalDependencies, TypeFamilies, FlexibleContexts, RankNTypes, GADTs, MultiParamTypeClasses, ScopedTypeVariables, FlexibleInstances, UndecidableInstances #-}
+-- {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
+module GArrowVerilog where
+import Control.GArrow
+import Control.Monad.State
+import Data.List (intercalate)
+import Control.Category
+import Control.Monad ((>=>), (<=<))
+import Prelude hiding (id, (.))
+import Text.PrettyPrint.HughesPJ
+import BitSerialHardware
+import GArrowPretty
+
+
+------------------------------------------------------------------------------
+-- Declaration Types (basically (Tree ()))
+
+data DeclType t where
+ DeclTypeUnit :: DeclType ()
+ DeclTypeWire :: DeclType Wire
+ DeclTypePair :: DeclType x -> DeclType y -> DeclType (x,y)
+
+instance Show (DeclType t) where
+ show DeclTypeUnit = "()"
+ show DeclTypeWire = "Wire"
+ show (DeclTypePair x y) = case x of
+ DeclTypePair _ _ -> "(" ++ show x ++ ")*" ++ show y
+ _ -> show x ++ "*" ++ show y
+
+------------------------------------------------------------------------------
+-- Identifiers
+
+data Id t where
+ IdUnit :: Id ()
+ IdWire :: String -> Id Wire
+ IdPair :: Id x -> Id y -> Id (x,y)
+
+instance Show (Id t) where
+ show IdUnit = "()"
+ show (IdWire n) = n
+ show (IdPair x y) = (show x) ++ "," ++ (show y)
+
+id2shape :: Id t -> DeclType t
+id2shape IdUnit = DeclTypeUnit
+id2shape (IdWire _) = DeclTypeWire
+id2shape (IdPair x y) = DeclTypePair (id2shape x) (id2shape y)
+
+
+------------------------------------------------------------------------------
+-- Verilog Writer
+
+class Monad vw => VerilogWriter vw where
+ declareWire :: DeclType t -> vw (Id t)
+ gate :: String -> [Id Wire] -> vw ()
+
+instance MonadState VState m => VerilogWriter m where
+ declareWire DeclTypeUnit = return IdUnit
+ declareWire (DeclTypePair x y) = do ix <- declareWire x ; iy <- declareWire y ; return $ IdPair ix iy
+ declareWire DeclTypeWire = do (VState x decls out) <- get
+ let ids = "wire"++(show x)
+ put $ VState (x+1) ((text "wire" <+> text ids <> semi):decls) out
+ return $ IdWire $ ids
+ gate name inputs = let output = text name <+> (parens $ hsep $ punctuate comma $ map (text . show) inputs) <> semi
+ in do (VState x decls out) <- get
+ put $ VState x decls (output:out)
+
+
+------------------------------------------------------------------------------
+-- Instance of Verilog Writer
+
+data VState = VState Int [Doc] [Doc]
+
+data V vw x y = V
+ { infer :: DeclType x -> DeclType y
+ , write :: Id x -> vw (Id y)
+ }
+
+instance VerilogWriter vw => Category (V vw) where
+ id = V { infer = id
+ , write = return }
+ g . f = V { infer = infer g . infer f
+ , write = write g <=< write f }
+
+
+
+------------------------------------------------------------------------------
+-- GArrow implementation
+
+instance VerilogWriter vw => GArrow (V vw) (,) () where
+ ga_cancell = V { infer = \(DeclTypePair DeclTypeUnit sx) -> sx
+ , write = \(IdPair IdUnit x) -> return x }
+ ga_cancelr = V { infer = \(DeclTypePair sx DeclTypeUnit) -> sx
+ , write = \(IdPair x IdUnit) -> return x }
+ ga_uncancell = V { infer = \s -> DeclTypePair DeclTypeUnit s
+ , write = \x -> return (IdPair IdUnit x) }
+ ga_uncancelr = V { infer = \s -> DeclTypePair s DeclTypeUnit
+ , write = \x -> return (IdPair x IdUnit) }
+ ga_assoc = V { infer = \(DeclTypePair (DeclTypePair sx sy) sz) -> DeclTypePair sx (DeclTypePair sy sz)
+ , write = \(IdPair (IdPair x y) z) -> return $ IdPair x (IdPair y z) }
+ ga_unassoc = V { infer = \(DeclTypePair sx (DeclTypePair sy sz)) -> (DeclTypePair (DeclTypePair sx sy) sz)
+ , write = \(IdPair x (IdPair y z)) -> return $ IdPair (IdPair x y) z }
+ ga_first f = V { infer = \(DeclTypePair sx sz) -> DeclTypePair (infer f sx) sz
+ , write = \(IdPair x z) -> do idy <- write f x ; return $ IdPair idy z }
+ ga_second f = V { infer = \(DeclTypePair sz sx) -> DeclTypePair sz (infer f sx)
+ , write = \(IdPair z x) -> do idy <- write f x ; return $ IdPair z idy }
+
+instance VerilogWriter vw => GArrowDrop (V vw) (,) () where
+ ga_drop = V { infer = \_ -> DeclTypeUnit
+ , write = \_ -> return IdUnit }
+
+instance VerilogWriter vw => GArrowCopy (V vw) (,) () where
+ ga_copy = V { infer = \s -> DeclTypePair s s
+ , write = \x -> return $ IdPair x x }
+
+instance VerilogWriter vw => GArrowSwap (V vw) (,) () where
+ ga_swap = V { infer = \(DeclTypePair x y) -> DeclTypePair y x
+ , write = \(IdPair x y) -> return $ IdPair y x }
+
+instance VerilogWriter vw => GArrowLoop (V vw) (,) () where
+ ga_loopl f = ga_loopr $ ga_swap >>> f >>> ga_swap
+ ga_loopr f = V { infer = \x -> let yz = infer f (DeclTypePair x (case yz of (DeclTypePair y z) -> z))
+ in (case yz of (DeclTypePair y z) -> y)
+ , write = \idx -> let yz = infer f (DeclTypePair (id2shape idx) (case yz of (DeclTypePair y z) -> z))
+ in case yz of (DeclTypePair y z) -> do idz <- declareWire z
+ idyz <- write f (IdPair idx idz)
+ return (case idyz of (IdPair y z) -> y)
+ }
+
+gate1 :: VerilogWriter vw => String -> Id Wire -> vw (Id Wire)
+gate1 name x =
+ do out <- declareWire DeclTypeWire
+ gate name [out,x]
+ return out
+
+gate2 :: VerilogWriter vw => String -> Id (Wire,Wire) -> vw (Id Wire)
+gate2 name (IdPair x y) =
+ do out <- declareWire DeclTypeWire
+ gate name [out,x,y]
+ return out
+
+gate3 :: VerilogWriter vw => String -> Id (Wire,(Wire,Wire)) -> vw (Id Wire)
+gate3 name (IdPair x (IdPair y z)) =
+ do out <- declareWire DeclTypeWire
+ gate name [out,x,y,z]
+ return out
+
+instance VerilogWriter vw => BitSerialHardwarePrimitives (V vw) where
+ high = V { infer = const DeclTypeWire , write = const $ return $ IdWire "1'b1" }
+ low = V { infer = const DeclTypeWire , write = const $ return $ IdWire "1'b0" }
+ not = V { infer = const DeclTypeWire , write = gate1 "not" }
+ xor = V { infer = const DeclTypeWire , write = gate2 "xor" }
+ or = V { infer = const DeclTypeWire , write = gate2 "or" }
+ and = V { infer = const DeclTypeWire , write = gate2 "and" }
+ mux2 = V { infer = const DeclTypeWire , write = gate3 "mux2" }
+ maj3 = V { infer = const DeclTypeWire , write = gate3 "maj3" }
+ reg = V { infer = const DeclTypeWire , write = gate1 "reg" }
+ loop vals = undefined
+ fifo len = undefined
+ probe id = undefined
+ oracle id = undefined
+
+
+------------------------------------------------------------------------------
+-- Examples
+
+oscillator :: BitSerialHardwarePrimitives v => v Wire Wire
+oscillator = ga_loopl $ ga_first reg >>> xor >>> ga_copy
+
+sample2 :: MonadState VState m => V m Wire Wire
+sample2 = oscillator
+
+sample3 :: V (StateT VState IO) Wire Wire
+sample3 = sample2
+
+writeModule moduleName verilog =
+ do (VState _ decls out) <- execStateT (write verilog (IdWire "inputWire")) (VState 0 [] [])
+ let portNames = [ "inputWire" ]
+ let ports = map text portNames
+ let out' = vcat [ text "module" <+> text moduleName <> (parens $ sep $ punctuate comma ports)
+ , nest 2 (vcat $ reverse decls)
+ , text ""
+ , nest 2 (vcat $ reverse out)
+ , text "endmodule"
+ ]
+ return out'
+
+main :: IO ()
+main = do putStrLn $ renderStyle (style{mode=PageMode, ribbonsPerLine=0.1}) $ pprGArrow oscillator
+ putStrLn ""
+ out' <- writeModule "foo" sample3
+ putStrLn $ renderStyle (style{mode=PageMode, ribbonsPerLine=0.1}) out'
+
+submodule :: V vw inputs outputs -> V vw inputs outputs
+submodule = undefined
+
+--main = do putStrLn $ show (DeclTypePair (DeclTypePair DeclTypeWire DeclTypeUnit) (DeclTypePair DeclTypeUnit DeclTypeWire))
--- /dev/null
+{-# OPTIONS_GHC -XModalTypes -dcore-lint -XScopedTypeVariables -ddump-types -XTypeFamilies -XNoMonomorphismRestriction #-}
+module Demo (demo, demo2) where
+
+{-
+demo ::
+ <[ \input ->
+ let delayed = ~~reg output
+ output = ~~xor input delayed
+ in output ]>
+-}
+
+demo z = <[ \y -> ~~z ]>
+
+demo2 :: <[ (a,b) ~~> c ]>@d -> <[ () ~~> a ]>@d -> <[ b ~~>c ]>@d
+demo2 x y = <[ ~~x ~~y ]>
+
+swap :: <[ (a,(b,c)) ~~> d ]>@e -> <[ (b,(a,c)) ~~> d ]>@e
+swap f = <[ \x -> \y -> ~~f y x ]>
+
+-- bad = <[ \f -> \x -> f x ]>
+
+demo3 x y z q = <[ ~~q (~~x ~~y ~~z) ]>
+
+
+
+class BitSerialHardwarePrimitives g where
+ type Wire
+
+ <[ not ]> :: <[ (Wire,()) ~~> Wire ]>@g
+ <[ xor ]> :: <[ (Wire,(Wire,())) ~~> Wire ]>@g
+ <[ or ]> :: <[ (Wire,(Wire,())) ~~> Wire ]>@g
+ <[ and ]> :: <[ (Wire,(Wire,())) ~~> Wire ]>@g
+ <[ mux2 ]> :: <[ (Wire,(Wire,(Wire,()))) ~~> Wire ]>@g
+ <[ maj3 ]> :: <[ (Wire,(Wire,(Wire,()))) ~~> Wire ]>@g
+ <[ reg ]> :: <[ (Wire,()) ~~> Wire ]>@g
+ <[ zero ]> :: <[ () ~~> Wire ]>@g
+ <[ one ]> :: <[ () ~~> Wire ]>@g
+
+ loop :: [Bool] -> <[ () ~~> Wire ]>@g
+ <[ lfsr ]> :: Int -> [ <[ Wire ]>@g ]
+ <[ adder ]> :: <[ (Wire,(Wire,())) ~~> Wire ]>@g
+ fifo :: Int -> <[ (Wire,()) ~~> Wire ]>@g
+
+ <[ probe ]> :: Int -> <[ (Wire,()) ~~> Wire ]>@g
+ <[ oracle ]> :: Int -> <[ Wire ]>@g
+
+xor3 :: forall g . BitSerialHardwarePrimitives g => <[ (Wire,(Wire,(Wire,()))) ~~> Wire ]>@g
+xor3 = <[ \x -> \y -> \z -> xor (xor x y) z ]>
+
+adder =
+ <[ \in1 ->
+ \in2 ->
+ let firstBitMarker = ~~(loop [ i/=0 | i <- [0..31] ])
+ carry_out = reg (mux2 firstBitMarker zero carry_in)
+ carry_in = maj3 carry_out in1 in2
+ in ~~xor3 carry_out in1 in2
+ ]>
+
+
+rotRight n =
+ <[ \input ->
+ let sel = ~~(loop [ i >= 32-n | i<-[0..31] ])
+ fifo1 = ~~(fifo (32-n)) input
+ fifo2 = ~~(fifo 32 ) fifo1
+ in mux2 sel fifo1 fifo2
+ ]>
+
+sha256round =
+ <[ \load ->
+ \input ->
+ \k_plus_w ->
+ let a = ~~(fifo 32) (mux2 load a_in input)
+ b = ~~(fifo 32) a
+ c = ~~(fifo 32) b
+ d = ~~(fifo 32) c
+ e = ~~(fifo 32) (mux2 load e_in d)
+ f = ~~(fifo 32) e
+ g = ~~(fifo 32) f
+ h = ~~(fifo 32) g
+ s0 = ~~xor3
+ (~~(rotRight 2) a_in)
+ (~~(rotRight 13) a_in)
+ (~~(rotRight 22) a_in)
+ s1 = ~~xor3
+ (~~(rotRight 6) e_in)
+ (~~(rotRight 11) e_in)
+ (~~(rotRight 25) e_in)
+ a_in = adder t1 t2
+ e_in = adder t1 d
+ t1 = adder
+ (adder h s1)
+ (adder (mux2 e g f)
+ k_plus_w)
+ t2 = adder s0 (maj3 a b c)
+ in h
+ ]>
--- /dev/null
+# -fwarn-incomplete-patterns
+
+ghc = ../../../inplace/bin/ghc-stage2
+#ghc = ghc
+ghc_opt := -Werror -odir .build -hidir .build
+
+open:
+ make demo
+ open .build/test.pdf
+
+#sanity += BiGArrow.hs
+sanity += IFLDemos.hs
+sanity += CircuitExample.hs
+sanity += CommandSyntaxExample.hs
+sanity += DotProduct.hs
+sanity += GArrowTutorial.hs
+sanity += GArrowVerilog.hs
+sanity += ImmutableHeap.hs
+sanity += IsomorphismForCodeTypes.hs
+sanity += LambdaCalculusInterpreter.hs
+sanity += TypeSafeRun.hs
+#sanity += Unflattening.hs
+
+sanity_opts = -dcore-lint -fforce-recomp -fcoqpass -ddump-coqpass -ddump-to-file
+sanity_opts += -fsimpleopt-before-flatten
+sanity_opts += -odir .build -hidir .build
+
+sanity:
+ for A in $(sanity); do echo; echo; $(ghc) $(sanity_opts) $$A +RTS -K500M || exit -1; done
+
+demo-pretty:
+ $(ghc) $(ghc_opt) -main-is GArrowPretty GArrowPretty.hs -o GArrowPretty
+
+demo-v:
+ $(ghc) $(ghc_opt) -main-is GArrowVerilog GArrowVerilog.hs -o GArrowVerilog
+ ./GArrowVerilog
+
+demo-verilog:
+ $(ghc) $(sanity_opts) -c VerilogDemo.hs
+ $(ghc) $(ghc_opt) -main-is GArrowVerilog GArrowVerilog.hs -o GArrowVerilog
+ ./GArrowVerilog
+
+demo:
+ mkdir -p .build
+ $(ghc) $(ghc_opt) -c Demo.hs -fforce-recomp
+ $(ghc) $(ghc_opt) --show-iface .build/Demo.hi
+ $(ghc) $(ghc_opt) GArrowTikZ.hs Demo.hs DemoMain.hs Unify.hs -o .build/demo
+ ./.build/demo > .build/test.tex
+ cd .build; TEXINPUTS=../tex-bits/:$TEXINPUTS: pdflatex test.tex
--- /dev/null
+{-# OPTIONS_GHC -XModalTypes -dcore-lint -ddump-types -XNoMonomorphismRestriction #-}
+module Stack where
+import Prelude hiding (const)
+
+class ProcessNetwork g where
+ logic :: ( Bool -> Bool) -> <[ Bool ~~> Bool ]>
+ logic2 :: (Bool -> Bool -> Bool) -> <[ (Bool,Bool) ~~> Bool ]>
+ delay :: Bool -> <[ Bool ~~> Bool ]>
+ select :: <[ (Bool,Bool,Bool) ~~> Bool ]>
+ switch :: <[ (Bool,Bool) ~~> (Bool,Bool) ]>
+
+------------------------------------------------------------------------------
+--
+-- Basic logic functions
+--
+and' = logic2 (\x y -> x && y)
+or' = logic2 (\x y -> x || y)
+not' = logic (\x -> case x of {True->False ; False -> True})
+
+--
+-- Simulates "conditionally consuming" data from an input port.
+--
+-- A value is consumed from "next"; if the value is False,
+-- the previous output is repeated. Otherwise, a value is
+-- consumed from "input" and emitted as the output.
+--
+--peek :: <[ (Bool,Bool) ~~> Bool ]>
+peek input next =
+ <[ \input ->
+ \next ->
+ let
+ prev = ~~(delay True) next
+ out = select prev input feedback
+-- (feedback,_) = switch next out
+ feedback = switch' next out
+ in out
+ ]>
+
+
+------------------------------------------------------------------------------
+--
+-- Numbers are represented in unary (Peano) notation: the number N is
+-- N-many False values followed by a single True
+--
+type Number = Bool
+
+
+--
+-- Convert a Number to a sequence of False's; the second argument
+-- is a stream of Bools, one per Number, indicating whether or not
+-- to include the trailing "True"
+--
+--numberToBooleans :: <[ (Number,Bool) ~~> Bool ]>
+allTrues :: forall g . <[ () ~~> Bool ]>@g
+allTrues = undefined
+allFalses :: forall g . <[ () ~~> Bool ]>@g
+allFalses = undefined
+
+numberToBooleans =
+ <[ \numbers ->
+ \includeTrailingTrue ->
+ let sel = select numbers includeTrailingTrue ~~allTrues
+-- (out,_) = switch sel numbers
+ out = switch' sel numbers
+ in out
+ ]>
+
+
+------------------------------------------------------------------------------
+--
+-- Increment, decrement, and zero-test for Numbers. Each of these
+-- follows a similar pattern: keep a copy of the previous input, and
+-- "pattern match" on a pair of consecutive bits.
+--
+--decrement :: <[ Number ~~> Number ]>
+decrement =
+ <[ \input ->
+ let isFirstBitOfNumber = ~~(delay True) input
+ isFirstBitOfNonzeroNumber = ~~and' (~~not' input) isFirstBitOfNumber
+-- (_,out) = switch isFirstBitOfNonzeroNumber input
+ out = switch' isFirstBitOfNonzeroNumber input
+ in out
+ ]>
+
+--increment :: <[ Number ~~> Number ]>
+increment =
+ <[ \input ->
+ let isFirstBitOfNumber = ~~(delay True) out
+ out = select isFirstBitOfNumber ~~allFalses input
+ in out
+ ]>
+
+--isZero :: <[ Number ~~> Bool ]>
+isZero =
+ <[ \input ->
+ let prev = ~~(delay True) input
+-- (out,_) = switch input (~~and' prev input)
+ out = switch' input (~~and' prev input)
+ in out
+ ]>
+
+
+------------------------------------------------------------------------------
+--
+-- Versions of the "select" and "select" operators that act on Numbers
+-- (the "select" port is still boolean).
+--
+-- numberSelect :: <[ (Bool,Number,Number) ~~> Number ]>
+{-
+numberSelect =
+ <[ \sel ->
+ \iftrue ->
+ \iffalse ->
+ let sel' = ~~peek sel next_sel
+ out = select sel' iftrue iffalse
+ next_sel = out
+ in out
+ ]>
+-}
+
+numberSwitch :: <[ (Bool,Number) ~~> (Number,Number) ]>
+{-
+numberSwitch =
+ <[ \sel ->
+ \input ->
+ let sel' = ~~peek sel next_sel
+ out = switch sel' input
+ next_sel = input
+ in out
+ ]>
+-}
+
+numberSelect :: <[ (Bool,(Number,(Number,()))) ~~> Number ]>@g
+numberSelect = undefined
+
+------------------------------------------------------------------------------
+--
+-- An example of a functional: given two process networks which each
+-- take a Number in and produce a Number output, route each incoming
+-- Number to one side or the other based on a control token.
+--
+{-
+maybeNumber :: ([Number] -> [Number]) ->
+ ([Number] -> [Number]) ->
+ [Bool] ->
+ [Number] ->
+ [Number]
+
+maybeNumber ftrue ffalse sel input =
+ let (inputTrue,inputFalse) = numberSwitch sel input
+ in numberSelect sel (ftrue inputTrue) (ffalse inputFalse)
+-}
+maybeNumber ::
+ <[ Number ~~> Number ]>@g ->
+ <[ Number ~~> Number ]>@g ->
+ <[ (Bool,Number) ~~> Number ]>@g
+maybeNumber = undefined
+
+
+------------------------------------------------------------------------------
+stack =
+ <[ \commandIsPop ->
+ \push ->
+ let
+ -- relatively straightforward: the counter, counter update, and emptiness test:
+ count = ~~(delay True) newCount
+ newCount = ~~maybeNumber ~~decrement ~~increment commandIsPop count
+ isEmpty = ~~isZero count
+ pushOrPopEmpty = ~~or' (~~not' commandIsPop) isEmpty
+
+ -- First stage: popping from an empty stack is implemented by
+ -- synthesizing a zero value, pushing it, and then popping it.
+ -- This first stage synthesizes the zero-value if necessary
+ (popEmptyResult,_) = ~~numberSwitch
+ pushOrPopEmpty
+ (~~numberSelect
+ commandIsPop
+ ~~allTrues
+ push)
+
+ -- Second stage: this select copies the existing stack storage
+ -- from its first input to its output, optionally *preceding* it
+ -- with a single value drawn from its second input.
+ pushResult = ~~numberSelect
+ (~~numberToBooleans count pushOrPopEmpty)
+ popEmptyResult
+ stackStorage
+
+ -- Third stage: copy the result of the "push" operation to its
+ -- second output, optionally diverting the *first* element to the
+ -- first output.
+ (popResult,stackStorage) = ~~numberSwitch
+ (numberToBooleans newCount commandIsPop)
+ pushResult
+
+ in popResult
+ ]>
+
+{-
+
+------------------------------------------------------------------------------
+--
+-- Boilerplate
+--
+
+
+int2p 0 = [True]
+int2p n = False:(int2p (n-1))
+
+
+p2i (True:xs) = 0:(p2i xs)
+p2i (False:xs) = case p2i xs of n:ns -> (n+1):ns
+p2i _ = []
+
+--x = peek [1,2,3,4,5,6,7,8] [True,True,False,False,True,False]
+--x = p2i $ numberSelect [False,True,True,False] even odd
+--x = p2i $ fst (numberSwitch [False,True,True,False,True] all)
+--x = p2i $ increment even
+x = p2i $ stack [True,True,False,False,False,True,True,False,True,True,True,True,True] odd
+ where
+ even = concatMap int2p [9,0,2,4,6]
+ odd = concatMap int2p [9,1,3,5]
+ all = concatMap int2p [1,2,0,2,3,4,9,9]
+
+main = do sequence $ map putStrLn $ map show x
+
+logic1 f in1 = map f in1
+logic2 f in1 in2 = map f (zip in1 in2)
+
+delay x = \n -> x:n
+
+select sel iftrue iffalse =
+ case sel of
+ (True :sel') -> case iftrue of { (x:iftrue') -> x:(select sel' iftrue' iffalse) ; _ -> [] }
+ (False:sel') -> case iffalse of { (x:iffalse') -> x:(select sel' iftrue iffalse') ; _ -> [] }
+ [] -> []
+
+switch (True:sel) (x:inp) = let (out1,out2) = switch sel inp in ((x:out1),out2)
+switch (False:sel) (x:inp) = let (out1,out2) = switch sel inp in (out1,(x:out2))
+switch _ _ = ([],[])
+
+allTrues = delay True allTrues
+allFalses = delay False allFalses
+-}
\ No newline at end of file
--- /dev/null
+{-# OPTIONS_GHC -XModalTypes -dcore-lint -ddump-types -XNoMonomorphismRestriction #-}
+module TuringMachine (ProcessNetwork) where
+import Prelude hiding (const)
+
+class ProcessNetwork g where
+ logic :: (Bool -> Bool -> Bool) -> <[ (Bool,(Bool,())) ~~> Bool ]>@g
+ delay :: Bool -> <[ (Bool,()) ~~> Bool ]>@g
+ <[ select ]> :: <[ (Bool,(Bool,(Bool,()))) ~~> Bool ]>@g
+ <[ switch ]> :: <[ (Bool,(Bool,())) ~~> (Bool,Bool) ]>@g
+ <[ switch' ]> :: <[ (Bool,(Bool,())) ~~> Bool ]>@g
+
+
+or = logic (\x y -> x || y)
+
+not :: ProcessNetwork g => <[ (Bool,()) ~~> Bool ]>@g
+not = undefined
+
+
+
+
+-- every time it gets an input it spits out the same output value
+const :: ProcessNetwork g => Bool -> <[ (Bool,()) ~~> Bool ]>@g
+const = undefined
+
+--
+-- VERY IMPORTANT!
+--
+-- Bool is the type of booleans in Haskell.
+-- <[Bool]> is the type of a process network arc in which EACH TOKEN is a boolean.
+--
+-- This can lead to some slightly-confusing notation:
+--
+-- (Bool -> Bool) is a Haskell function that takes a boolean and
+-- (if it halts) returns a Boolean.
+--
+-- <[Bool ~~> Bool]> is a process network with an input arc whose
+-- tokens are booleans and an output arc whose
+-- tokens are booleans
+--
+
+--
+-- Think of Haskell values as being like Ptolemy model parameters!
+--
+
+condConst initVal =
+ <[ \condition -> ~~(const initVal) (switch' condition condition) ]>
+
+
+--
+-- The size of the stack is a natural number; these will be
+-- represented as a stream of values using *unary notation* in the
+-- following form: the number N is represented as "true" followed by
+-- N-many "false" values.
+--
+
+--
+-- A UnaryNumber is just a stream that we give a particular meaning
+-- to. We're going to get some help here from Haskell's type system
+-- by creating another type UnaryNumber, but not telling our code that
+-- it's actually the same thing as a Stream. This prevents us from
+-- accidentally using a non-UnaryNumber stream where a UnaryNumber was
+-- required!
+--
+type UnaryNumber = Bool
+
+
+type IncDec = Bool
+
+counter :: ProcessNetwork g => <[ IncDec ~~> UnaryNumber ]>@g
+counter = undefined
+
+
+
+
+
+-- show myself making a type error
+
+
+-- Investigate later: automatic translation from <[PeanoStream~~>PeanoStream]> to <[Bool~~>Bool]>
+
+-- show why innocuous Haskell program transforms alter the behavior of PNs
\ No newline at end of file
module Unflattening
where
import GHC.HetMet.CodeTypes hiding ((-))
-import GHC.HetMet.GArrow
+import Control.GArrow
import Control.Category
import Control.Arrow
import Prelude hiding ( id, (.) )
--- /dev/null
+-- | A very simple finite-sized-term unification engine; used by GArrowTikZ
+module Unify(UVar, Unifier, Unifiable(..), mergeU, emptyUnifier, getU, uvarSupply, unify, resolve)
+--
+-- | Terminology: a value of type @t@ (for which an instance
+-- @Unifiable t@ exists) is "fully resolved" with respect to some
+-- value of type @Unifier t@ if no @UVar@ which occurs in the
+-- @t@-value is a key in the unifier map.
+--
+where
+import Prelude hiding (lookup)
+import Data.Map hiding (map)
+import Data.Tree
+import Data.List (nub)
+import Control.Monad.Error
+
+-- | a unification variable
+newtype UVar = UVar Int
+ deriving (Ord, Eq)
+
+instance Show UVar where
+ show (UVar v) = "u" ++ show v
+
+-- | A unifier is a map from unification /variables/ to unification
+-- /values/ of type @t@. Invariant: values of the map are always
+-- fully resolved with respect to the map.
+data Unifier t = Unifier (Map UVar t)
+ | UnifierError String
+
+-- | Resolves a unification variable according to a Unifier.
+getU :: Unifier t -> UVar -> Maybe t
+getU (Unifier u) v = lookup v u
+getU (UnifierError e) v = error e
+
+-- | An infinite supply of distinct unification variables.
+uvarSupply :: [UVar]
+uvarSupply = uvarSupply' 0
+ where
+ uvarSupply' n = (UVar n):(uvarSupply' $ n+1)
+
+-- | The empty unifier.
+emptyUnifier :: Unifier t
+emptyUnifier = Unifier empty
+
+-- | Types for which we know how to do unification.
+class Show t => Unifiable t where
+
+ -- | Turns a @UVar@ into a @t@
+ inject :: UVar -> t
+
+ -- | Discern if a @t@ is a @UVar@. Invariant: @(project (inject x) == x)@
+ project :: t -> Maybe UVar
+
+ -- | Instances must implement this; it is called by @(unify x y)@
+ -- only when both @(project x)@ and @(project y)@ are @Nothing@
+ unify' :: t -> t -> Unifier t
+
+ -- | Returns a list of all @UVars@ occurring in @t@
+ occurrences :: t -> [UVar]
+
+ -- | @(replace vrep trep t)@ returns a copy of @t@ in which all occurrences of @vrep@ have been replaced by @trep@
+ replace :: UVar -> t -> t -> t
+
+-- | Returns a copy of the @t@ argument in which all @UVar@
+-- occurrences have been replaced by fully-resolved @t@ values.
+resolve :: Unifiable t => Unifier t -> t -> t
+resolve (UnifierError e) _ = error e
+resolve (Unifier m) t = resolve' (toList m) t
+ where
+ resolve' [] t = t
+ resolve' ((uv,v):rest) t | Just uvt <- project t = if uvt == uv
+ then v -- we got this out of the unifier, so it must be fully resolved
+ else resolve' rest t
+ | otherwise = resolve' rest (replace uv v t)
+
+-- | Given two unifiables, find their most general unifier.
+unify :: Unifiable t => t -> t -> Unifier t
+unify v1 v2 | (Just v1') <- project v1, (Just v2') <- project v2, v1'==v2' = emptyUnifier
+unify v1 v2 | (Just v1') <- project v1 = if elem v1' (occurrences v2)
+ then UnifierError "occurs check failed in Unify.unify"
+ else Unifier $ insert v1' v2 empty
+unify v1 v2 | (Just v2') <- project v2 = unify v2 v1
+unify v1 v2 | _ <- project v1, _ <- project v2 = unify' v1 v2
+
+-- | Merge two unifiers into a single unifier.
+mergeU :: Unifiable t => Unifier t -> Unifier t -> Unifier t
+mergeU ue@(UnifierError _) _ = ue
+mergeU (Unifier u) u' = foldr (\(k,v) -> \uacc -> mergeU' uacc k (resolve uacc v)) u' (toList u)
+ where
+ mergeU' ue@(UnifierError _) _ _ = ue
+ mergeU' u@(Unifier m) v1 v2 | member v1 m = mergeU u $ unify (m ! v1) v2
+ | Just v2' <- project (resolve u v2), v2' == v1 = u
+ | elem v1 (occurrences v2) = UnifierError "occurs check failed in Unify.mergeU"
+ | otherwise = Unifier $ insert v1 v2 m
+
+-- | Enumerates the unification variables, sorted by occurs-check.
+sortU :: (Unifiable t, Eq t) => Unifier t -> [UVar]
+sortU u@(Unifier um) = reverse $ nub $ concatMap (\k -> occurrences (um!k)) (keys um)
+sortU (UnifierError ue) = error ue
--- /dev/null
+{-# OPTIONS_GHC -XModalTypes -fflatten -funsafe-skolemize -dcore-lint -XScopedTypeVariables -fsimpleopt-before-flatten -XKindSignatures #-}
+module VerilogDemo (oscillator) where
+
+oscillator :: <[ (w,()) ~~> w ]>@a -> <[ (w,(w,())) ~~> w ]>@a -> <[ (w,()) ~~> w ]>@a
+oscillator reg xor =
+ <[ \input ->
+ let output = ~~xor input delayed
+ delayed = ~~reg output
+ in output ]>
--- /dev/null
+%%
+%% This is file `prauctex.def',
+%% generated with the docstrip utility.
+%%
+%% The original source files were:
+%%
+%% preview.dtx (with options: `auctex')
+%%
+%% IMPORTANT NOTICE:
+%%
+%% For the copyright see the source file.
+%%
+%% Any modified versions of this file must be renamed
+%% with new filenames distinct from prauctex.def.
+%%
+%% For distribution of the original source see the terms
+%% for copying and modification in the file preview.dtx.
+%%
+%% This generated file may be distributed as long as the
+%% original source files, as listed above, are part of the
+%% same distribution. (The sources need not necessarily be
+%% in the same archive or directory.)
+%% The preview style for extracting previews from LaTeX documents.
+%% Developed as part of AUCTeX <URL:http://www.gnu.org/software/auctex>.
+\ifPreview\else\expandafter\endinput\fi
+\nofiles
+\preview@delay{\nonstopmode}
+\begingroup
+\lccode`\~=`\-
+\lccode`\{=`\<
+\lccode`\}=`\>
+\lowercase{\endgroup
+ \def\pr@msgi{{~}}}
+\def\pr@msgii{Preview:
+ Snippet \number\pr@snippet\space}
+\begingroup
+\catcode`\-=13
+\catcode`\<=13
+\@firstofone{\endgroup
+\def\pr@msg#1{{%
+ \let<\pr@msgi
+ \def-{\pr@msgii#1}%
+ \errhelp{Not a real error.}%
+ \errmessage<}}}
+\g@addto@macro\pr@ship@start{\pr@msg{started}}
+\g@addto@macro\pr@ship@end{\pr@msg{ended.%
+ (\number\ht\pr@box+\number\dp\pr@box x\number\wd\pr@box)}}
+\hbadness=\maxdimen
+\newcount\hbadness
+\vbadness=\maxdimen
+\let\vbadness=\hbadness
+\hfuzz=\maxdimen
+\newdimen\hfuzz
+\vfuzz=\maxdimen
+\let\vfuzz=\hfuzz
+\showboxdepth=-1
+\showboxbreadth=-1
+\pr@loadcfg{prauctex}
+\endinput
+%%
+%% End of file `prauctex.def'.
--- /dev/null
+%%
+%% This is file `prcounters.def',
+%% generated with the docstrip utility.
+%%
+%% The original source files were:
+%%
+%% preview.dtx (with options: `counters')
+%%
+%% IMPORTANT NOTICE:
+%%
+%% For the copyright see the source file.
+%%
+%% Any modified versions of this file must be renamed
+%% with new filenames distinct from prcounters.def.
+%%
+%% For distribution of the original source see the terms
+%% for copying and modification in the file preview.dtx.
+%%
+%% This generated file may be distributed as long as the
+%% original source files, as listed above, are part of the
+%% same distribution. (The sources need not necessarily be
+%% in the same archive or directory.)
+%% The preview style for extracting previews from LaTeX documents.
+%% Developed as part of AUCTeX <URL:http://www.gnu.org/software/auctex>.
+\ifPreview\else\expandafter\endinput\fi
+\def\pr@eltprint#1{\expandafter\@gobble\ifnum\value{#1}=0%
+ \csname pr@c@#1\endcsname\else\relax
+ \space{#1}{\arabic{#1}}\fi}
+\def\pr@eltdef#1{\expandafter\xdef
+ \csname pr@c@#1\endcsname{\arabic{#1}}}
+\def\pr@ckpt#1{{\let\@elt\pr@eltprint\edef\next{\cl@@ckpt}%
+ \ifx\next\@empty\else\typeout{Preview: Counters\next#1}%
+ \let\@elt\pr@eltdef\cl@@ckpt\fi}}
+\pr@addto@front\pr@ship@start{\pr@ckpt:}
+\pr@addto@front\pr@ship@end{\pr@ckpt.}
+\endinput
+%%
+%% End of file `prcounters.def'.
--- /dev/null
+%%
+%% This is file `preview.drv',
+%% generated with the docstrip utility.
+%%
+%% The original source files were:
+%%
+%% preview.dtx (with options: `driver')
+%%
+%% IMPORTANT NOTICE:
+%%
+%% For the copyright see the source file.
+%%
+%% Any modified versions of this file must be renamed
+%% with new filenames distinct from preview.drv.
+%%
+%% For distribution of the original source see the terms
+%% for copying and modification in the file preview.dtx.
+%%
+%% This generated file may be distributed as long as the
+%% original source files, as listed above, are part of the
+%% same distribution. (The sources need not necessarily be
+%% in the same archive or directory.)
+%% The preview style for extracting previews from LaTeX documents.
+%% Developed as part of AUCTeX <URL:http://www.gnu.org/software/auctex>.
+ \documentclass{ltxdoc}
+ \usepackage{preview}
+ \let\ifPreview\relax
+ \newcommand\previewlatex{\texttt{preview-latex}}
+ \begin{document}
+ \DocInput{preview.dtx}
+ \end{document}
+\endinput
+%%
+%% End of file `preview.drv'.
--- /dev/null
+% \iffalse
+%% The preview style for extracting previews from LaTeX documents.
+%% Developed as part of AUCTeX <URL:http://www.gnu.org/software/auctex>.
+%
+% Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006,
+% 2010 Free Software Foundation
+%
+% 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, write to the
+% Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
+% Boston, MA 02110-1301 USA
+% \fi
+% \CheckSum{1758}
+% \GetFileInfo{preview.sty}
+% \date{\filedate}
+% \author{David Kastrup\thanks{\texttt{dak@gnu.org}}}
+% \title{The \texttt{preview} Package for \LaTeX\\Version \fileversion}
+% \maketitle
+% \section{Introduction}
+% The main purpose of this package is the extraction of certain
+% environments (most notably displayed formulas) from \LaTeX\ sources
+% as graphics. This works with DVI files postprocessed by either
+% Dvips and Ghostscript or dvipng, but it also works when you are
+% using PDF\TeX\ for generating PDF files (usually also postprocessed
+% by Ghostscript).
+%
+% Current uses of the package include the \previewlatex\ package for
+% WYSIWYG functionality in the AUC\TeX\ editing environment,
+% generation of previews in LyX, as part of the operation of the
+% ps4pdf package, the tbook XML system and some other tools.
+%
+% Producing EPS files with Dvips and its derivatives using the
+% \texttt{-E} option is not a good alternative: People make do by
+% fiddling around with |\thispagestyle{empty}| and hoping for the best
+% (namely, that the specified contents will indeed fit on single
+% pages), and then trying to guess the baseline of the resulting code
+% and stuff, but this is at best dissatisfactory. The preview package
+% provides an easy way to ensure that exactly one page per request
+% gets shipped, with a well-defined baseline and no page decorations.
+% While you still can use the preview package with the `classic'
+% \begin{quote}
+% |dvips -E -i|
+% \end{quote}
+% invocation, there are better ways available that don't rely on Dvips
+% not getting confused by PostScript specials.
+%
+% For most applications, you'll want to make use of the |tightpage|
+% option. This will embed the page dimensions into the PostScript or
+% PDF code, obliterating the need to use the |-E -i| options to Dvips.
+% You can then produce all image files with a single run of
+% Ghostscript from a single PDF or PostScript (as opposed to EPS)
+% file.
+%
+% Various options exist that will pass \TeX\ dimensions and other
+% information about the respective shipped out material (including
+% descender size) into the log file, where external applications might
+% make use of it.
+%
+% The possibility for generating a whole set of graphics with a single
+% run of Ghostscript (whether from \LaTeX\ or PDF\LaTeX) increases
+% both speed and robustness of applications. It is also feasible to
+% use dvipng on a DVI file with the options
+% \begin{quote}
+% |-picky -noghostscript|
+% \end{quote}
+% to omit generating any image file that requires Ghostscript, then
+% let a script generate all missing files using Dvips/Ghostscript.
+% This will usually speed up the process significantly.
+%
+% \section{Package options}
+% The package is included with the customary
+% \begin{quote}
+% |\usepackage|\oarg{options}|{preview}|
+% \end{quote}
+% You should usually load this package as the last one, since it
+% redefines several things that other packages may also provide.
+%
+% The following options are available:
+% \begin{description}
+% \item[|active|] is the most essential option. If this option is not
+% specified, the |preview| package will be inactive and the document
+% will be typeset as if the |preview| package were not loaded,
+% except that all declarations and environments defined by the
+% package are still legal but have no effect. This allows defining
+% previewing characteristics in your document, and only activating
+% them by calling \LaTeX\ as
+% \begin{quote}
+% \raggedright
+% |latex '\PassOptionsToPackage{active}{preview}| |\input|\marg{filename}|'|
+% \end{quote}
+% \item[|noconfig|] Usually the file |prdefault.cfg| gets loaded
+% whenever the |preview| package gets activated. |prdefault.cfg| is
+% supposed to contain definitions that can cater for otherwise bad
+% results, for example, if a certain document class would otherwise
+% lead to trouble. It also can be used to override any settings
+% made in this package, since it is loaded at the very end of it.
+% In addition, there may be configuration files specific for certain
+% |preview| options like |auctex| which have more immediate needs.
+% The |noconfig| option suppresses loading of those option files,
+% too.
+% \item[|psfixbb|] Dvips determines the bounding boxes from the
+% material in the DVI file it understands. Lots of PostScript
+% specials are not part of that. Since the \TeX\ boxes do not make
+% it into the DVI file, but merely characters, rules and specials
+% do, Dvips might include far too small areas. The option |psfixbb|
+% will include |/dev/null| as a graphic file in the ultimate upper
+% left and lower right corner of the previewed box. This will make
+% Dvips generate an appropriate bounding box.
+% \item[|dvips|] If this option is specified as a class option or to
+% other packages, several packages pass things like page size
+% information to Dvips, or cause crop marks or draft messages
+% written on pages. This seriously hampers the usability of
+% previews. If this option is specified, the changes will be undone
+% if possible.
+% \item[|pdftex|] If this option is set, PDF\TeX\ is assumed as the
+% output driver. This mainly affects the |tightpage| option.
+% \item[|xetex|] If this option is set, Xe\TeX\ is assumed as the
+% output driver. This mainly affects the |tightpage| option.
+% \item[|displaymath|] will make all displayed math environments
+% subject to preview processing. This will typically be the most
+% desired option.
+% \item[|floats|] will make all float objects subject to preview
+% processing. If you want to be more selective about what floats to
+% pass through to a preview, you should instead use the
+% \cmd{\PreviewSnarfEnvironment} command on the floats you want to
+% have previewed.
+% \item[|textmath|] will make all text math subject to previews.
+% Since math mode is used throughly inside of \LaTeX\ even for other
+% purposes, this works by redefining \cmd\(, \cmd\)
+% and |$| and the |math| environment (apparently some people use
+% that). Only occurences of these text math delimiters in later
+% loaded packages and in the main document will thus be affected.
+% \item[|graphics|] will subject all \cmd{\includegraphics} commands
+% to a preview.
+% \item[|sections|] will subject all section headers to a preview.
+% \item[|delayed|] will delay all activations and redefinitions the
+% |preview| package makes until |\||begin{document}|. The purpose
+% of this is to cater for documents which should be subjected to the
+% |preview| package without having been prepared for it. You can
+% process such documents with
+% \begin{quote}
+% |latex '\RequirePackage[active,delayed,|\meta{options}|]{preview}|
+% |\input|\marg{filename}|'|
+% \end{quote}
+% This relaxes the requirement to be loading the |preview| package
+% as last package.
+% \item[\meta{driver}] loads a special driver file
+% |pr|\meta{driver}|.def|. The remaining options are implemented
+% through the use of driver files.
+% \item[|auctex|] This driver will produce fake error messages at the
+% start and end of every preview environment that enable the Emacs
+% package \previewlatex\ in connection with AUC\TeX\ to pinpoint
+% the exact source location where the previews have originated.
+% Unfortunately, there is no other reliable means of passing the
+% current \TeX\ input position \emph{in} a line to external
+% programs. In order to make the parsing more robust, this option
+% also switches off quite a few diagnostics that could be
+% misinterpreted.
+%
+% You should not specify this option manually, since it will only be
+% needed by automated runs that want to parse the pseudo error
+% messages. Those runs will then use \cmd{\PassOptionsToPackage} in
+% order to effect the desired behaviour. In addition,
+% |prauctex.cfg| will get loaded unless inhibited by the |noconfig|
+% option. This caters for the most frequently encountered
+% problematic commands.
+% \item[|showlabels|] During the editing process, some people like to
+% see the label names in their equations, figures and the like. Now
+% if you are using Emacs for editing, and in particular
+% \previewlatex, I'd strongly recommend that you check out the
+% Ref\TeX\ package which pretty much obliterates the need for this
+% kind of functionality. If you still want it, standard \LaTeX\
+% provides it with the |showkeys| package, and there is also the
+% less encompassing |showlabels| package. Unfortunately, since
+% those go to some pain not to change the page layout and spacing,
+% they also don't change |preview|'s idea of the \TeX\ dimensions of
+% the involved boxes. So if you are using |preview| for determing
+% bounding boxes, those packages are mostly useless. The option
+% |showlabels| offers a substitute for them.
+% \item[|tightpage|] It is not uncommon to want to use the results of
+% |preview| as graphic images for some other application. One
+% possibility is to generate a flurry of EPS files with
+% \begin{quote}
+% |dvips -E -i -Pwww -o| \meta{outputfile}|.000| \meta{inputfile}
+% \end{quote}
+% However, in case those are to be processed further into graphic
+% image files by Ghostscript, this process is inefficient since all
+% of those files need to be processed one by one. In addition, it
+% is necessary to extract the bounding box comments from the EPS
+% files and convert them into page dimension parameters for
+% Ghostscript in order to avoid full-page graphics. This is not
+% even possible if you wanted to use Ghostscript in a~\emph{single}
+% run for generating the files from a single PostScript file, since
+% Dvips will in that case leave no bounding box information
+% anywhere.
+%
+% The solution is to use the |tightpage| option. That way a single
+% command line like
+% \begin{quote}
+% \raggedright
+% \texttt{gs -sDEVICE=png16m -dTextAlphaBits=4 -r300
+% -dGraphicsAlphaBits=4 -dSAFER -q -dNOPAUSE
+% -sOutputFile=\meta{outputfile}\%d.png \meta{inputfile}.ps}
+% \end{quote}
+% will be able to produce tight graphics from a single PostScript
+% file generated with Dvips \emph{without} use of the options
+% |-E -i|, in a single run.
+%
+% The |tightpage| option actually also works when using the |pdftex|
+% option and generating PDF files with PDF\TeX. The resulting PDF
+% file has separate page dimensions for every page and can directly
+% be converted with one run of Ghostscript into image files.
+%
+% If neither |dvips| or |pdftex| have been specified, the
+% corresponding option will get autodetected and invoked.
+%
+% If you need this in a batch environment where you don't want to
+% use |preview|'s automatic extraction facilities, no problem: just
+% don't use any of the extraction options, and wrap everything to be
+% previewed into |preview| environments. This is how LyX does its
+% math previews.
+%
+% If the pages under the |tightpage| option are just too tight, you
+% can adjust by setting the length |\PreviewBorder| to a different
+% value by using \cmd{\setlength}. The default value is
+% |0.50001bp|, which is half of a usual PostScript point, rounded
+% up. If you go below this value, the resulting page size may drop
+% below |1bp|, and Ghostscript does not seem to like that. If you
+% need finer control, you can adjust the bounding box dimensions
+% individually by changing the macro |\PreviewBbAdjust| with the
+% help of |\renewcommand|. Its default value is
+% \begin{quote}
+% \raggedright
+% |\newcommand| |\PreviewBbAdjust|
+% |{-\PreviewBorder| |-\PreviewBorder|
+% |\PreviewBorder| |\PreviewBorder}|
+% \end{quote}
+% This adjusts the left, lower, right and upper borders by the given
+% amount. The macro must contain 4~\TeX\ dimensions after another,
+% and you may not omit the units if you specify them explicitly
+% instead of by register. PostScript points have the unit~|bp|.
+% \item[|lyx|] This option is for the sake of LyX developers. It will
+% output a few diagnostics relevant for the sake of LyX' preview
+% functionality (at the time of writing, mostly implemented for math
+% insets, in versions of LyX starting with 1.3.0).
+% \item[|counters|] This writes out diagnostics at the start and the
+% end of previews. Only the counters changed since the last output
+% get written, and if no counters changed, nothing gets written at
+% all. The list consists of counter name and value, both enclosed
+% in |{}| braces, followed by a space. The last such pair is
+% followed by a colon (|:|) if it is at the start of the preview
+% snippet, and by a period (|.|) if it is at the end. The order of
+% different diagnostics like this being issued depends on the order
+% of the specification of the options when calling the package.
+%
+% Systems like \previewlatex\ use this for keeping counters accurate
+% when single previews are regenerated.
+% \item[|footnotes|] This makes footnotes render as previews, and only
+% as their footnote symbol. A convenient editing feature inside of
+% Emacs.
+% \end{description}
+% The following options are just for debugging purposes of the package
+% and similar to the corresponding \TeX\ commands they allude to:
+% \begin{description}
+% \item[|tracingall|] causes lots of diagnostic output to appear in
+% the log file during the preview collecting phases of \TeX's
+% operation. In contrast to the similarly named \TeX\ command, it
+% will not switch to |\errorstopmode|, nor will it change the
+% setting of |\tracingonline|.
+% \item[|showbox|] This option will show the contents of the boxes
+% shipped out to the DVI files. It also sets |\showboxbreadth| and
+% |\showboxdepth| to their maximum values at the end of loading this
+% package, but you may reset them if you don't like that.
+% \end{description}
+% \section{Provided Commands}
+% \DescribeEnv{preview} The |preview| environment causes its contents
+% to be set as a single preview image. Insertions like figures and
+% footnotes (except those included in minipages) will typically lead
+% to error messages or be lost. In case the |preview| package has not
+% been activated, the contents of this environment will be typeset
+% normally.
+%
+% \DescribeEnv{nopreview} The |nopreview| environment will cause its
+% contents not to undergo any special treatment by the |preview|
+% package. When |preview| is active, the contents will be discarded
+% like all main text that does not trigger the |preview| hooks. When
+% |preview| is not active, the contents will be typeset just like the
+% main text.
+%
+% Note that both of these environments typeset things as usual when
+% preview is not active. If you need something typeset conditionally,
+% use the \cmd{\ifPreview} conditional for it.
+%
+% \DescribeMacro{\PreviewMacro} If you want to make a macro like
+% \cmd{\includegraphics} (actually, this is what is done by the
+% |graphics| option to |preview|) produce a preview image, you put a
+% declaration like
+% \begin{quote}
+% |\PreviewMacro[*[[!]{\includegraphics}|
+% \end{quote}
+% or, more readable,
+% \begin{quote}
+% |\PreviewMacro[{*[][]{}}]{\includegraphics}|
+% \end{quote}
+% into your preamble. The optional argument to \cmd{\PreviewMacro}
+% specifies the arguments \cmd{\includegraphics} accepts, since this
+% is necessary information for properly ending the preview box. Note
+% that if you are using the more readable form, you have to enclose
+% the argument in a |[{| and |}]| pair. The inner braces are
+% necessary to stop any included |[]| pairs from prematurely ending
+% the optional argument, and to make a single |{}|
+% denoting an optional argument not get stripped away by \TeX's
+% argument parsing.
+%
+% The letters simply mean
+% \begin{description}
+% \item[|*|] indicates an optional |*| modifier, as in
+% |\includegraphics*|.
+% \item[|[|]^^A]
+% indicates an optional argument in brackets. This syntax
+% is somewhat baroque, but brief.
+% \item[{|[]|}] also indicates an optional argument in brackets. Be
+% sure to have encluded the entire optional argument specification
+% in an additional pair of braces as described above.
+% \item[|!|] indicates a mandatory argument.
+% \item[|\char`{\char`}|] indicates the same. Again, be sure to have
+% that additional level of braces around the whole argument
+% specification.
+% \item[|?|\meta{delimiter}\marg{true case}\marg{false case}] is a
+% conditional. The next character is checked against being equal to
+% \meta{delimiter}. If it is, the specification \meta{true case} is
+% used for the further parsing, otherwise \meta{false case} will be
+% employed. In neither case is something consumed from the input,
+% so \marg{true case} will still have to deal with the upcoming
+% delimiter.
+% \item[|@|\marg{literal sequence}] will insert the given sequence
+% literally into the executed call of the command.
+% \item[|-|] will just drop the next token. It will probably be most
+% often used in the true branch of a |?| specification.
+% \item[|\#|\marg{argument}\marg{replacement}] is a transformation
+% rule that calls a macro with the given argument and replacement
+% text on the rest of the argument list. The replacement is used in
+% the executed call of the command. This can be used for parsing
+% arbitrary constructs. For example, the |[]| option could manually
+% be implemented with the option string |?[{#{[#1]}{[{#1}]}}{}|.
+% PStricks users might enjoy this sort of flexibility.
+% \item[|:|\marg{argument}\marg{replacement}] is again a
+% transformation rule. As opposed to |#|, however, the result of
+% the transformation is parsed again. You'll rarely need this.
+% \end{description}
+%
+% There is a second optional argument in brackets that can be used to
+% declare any default action to be taken instead. This is mostly for
+% the sake of macros that influence numbering: you would want to keep
+% their effects in that respect. The default action should use |#1|
+% for referring to the original (not the patched) command with the
+% parsed options appended. Not specifying a second optional argument
+% here is equivalent to specifying~|[#1]|.
+%
+% \DescribeMacro{\PreviewMacro*} A similar invocation
+% \cmd{\PreviewMacro*} simply throws the macro and all of its
+% arguments declared in the manner above away. This is mostly useful
+% for having things like \cmd{\footnote} not do their magic on their
+% arguments. More often than not, you don't want to declare any
+% arguments to scan to \cmd{\PreviewMacro*} since you would want the
+% remaining arguments to be treated as usual text and typeset in that
+% manner instead of being thrown away. An exception might be, say,
+% sort keys for \cmd{\cite}.
+%
+% A second optional argument in brackets can be used to declare any
+% default action to be taken instead. This is for the sake of macros
+% that influence numbering: you would want to keep their effects in
+% that respect. The default action might use |#1| for referring to
+% the original (not the patched) command with the parsed options
+% appended. Not specifying a second optional argument here is
+% equivalent to specifying~|[]| since the command usually gets thrown
+% away.
+%
+% As an example for using this argument, you might want to specify
+% \begin{quote}
+% |\PreviewMacro*\footnote[{[]}][#1{}]|
+% \end{quote}
+% This will replace a footnote by an empty footnote, but taking any
+% optional parameter into account, since an optional paramter changes
+% the numbering scheme. That way the real argument for the footnote
+% remains for processing by \previewlatex.
+%
+% \DescribeMacro{\PreviewEnvironment} The macro
+% \cmd{\PreviewEnvironment} works just as \cmd{\PreviewMacro} does,
+% only for environments. \DescribeMacro{\PreviewEnvironment*} And the
+% same goes for \cmd{\PreviewEnvironment*} as compared to
+% \cmd{\PreviewMacro*}.
+%
+% \DescribeMacro{\PreviewSnarfEnvironment} This macro does not typeset
+% the original environment inside of a preview box, but instead
+% typesets just the contents of the original environment inside of the
+% preview box, leaving nothing for the original environment. This has
+% to be used for figures, for example, since they would
+% \begin{enumerate}
+% \item produce insertion material that cannot be extracted to the
+% preview properly,
+% \item complain with an error message about not being in outer par
+% mode.
+% \end{enumerate}
+%
+% \DescribeMacro{\PreviewOpen}
+% \DescribeMacro{\PreviewClose}
+% Those Macros form a matched preview pair. This is for macros that
+% behave similar as \cmd{\begin} and \cmd{\end} of an environment. It
+% is essential for the operation of \cmd{\PreviewOpen} that the macro
+% treated with it will open an additional group even when the preview
+% falls inside of another preview or inside of a |nopreview|
+% environment. Similarly, the macro treated with \cmd{PreviewClose}
+% will close an environment even when inactive.
+%
+% \DescribeMacro{\ifPreview} In case you need to know whether
+% |preview| is active, you can use the conditional \cmd{\ifPreview}
+% together with |\else| and |\fi|.
+%
+% \StopEventually{}
+% \section{The Implementation}
+% Here we go: the start is somewhat obtuse since we figure out version
+% number and date from RCS strings. This should really be done at
+% docstrip time instead. Takers?
+% \begin{macro}{\pr@version}
+% \begin{macrocode}
+%<*style>
+%<*!active>
+\NeedsTeXFormat{LaTeX2e} \def\reserved@a #1#2$#3:
+#4${\xdef#1{\reserved@c #2#4 $}} \def\reserved@c #1 #2${#1}
+\begingroup \catcode`\_=12
+\reserved@a\pr@version $Name: release_11_86 $ \ifx\pr@version\@empty
+\reserved@a\pr@version CVS-$Revision: 1.126 $ \endgroup \else
+ \def\next release_{} \lccode`\_=`.
+ \edef\next{\lowercase{\endgroup
+ \def\noexpand\pr@version{\expandafter\next\pr@version}}} \next \fi
+\reserved@a\next $Date: 2010/02/14 16:19:00 $
+\edef\next{\noexpand\ProvidesPackage{preview}%
+ [\next\space \pr@version\space (AUCTeX/preview-latex)]}
+\next
+% \end{macrocode}
+% \end{macro}
+% Since many parts here will not be needed as long as the package is
+% inactive, we will include them enclosed with |<*active>| and
+% |</active>| guards. That way, we can append all of this stuff at a
+% place where it does not get loaded if not necessary.
+%
+%\begin{macro}{\ifPreview}
+% Setting the \cmd{\ifPreview} command should not be done by the
+% user, so we don't use \cmd{\newif} here. As a consequence, there
+% are no \cmd{\Previewtrue} and \cmd{\Previewfalse} commands.
+% \begin{macrocode}
+\let\ifPreview\iffalse
+%</!active>
+% \end{macrocode}
+%\end{macro}
+%\begin{macro}{\ifpr@outer}
+% We don't allow previews inside of previews. The macro
+% \cmd{\ifpr@outer} can be used for checking whether we are outside
+% of any preview code.
+% \begin{macrocode}
+%<*active>
+\newif\ifpr@outer
+\pr@outertrue
+%</active>
+% \end{macrocode}
+%\end{macro}
+%
+%\begin{macro}{\preview@delay}
+% The usual meaning of \cmd{\preview@delay} is to just echo its
+% argument in normal |preview| operation. If |preview| is inactive,
+% it swallows its argument. If the |delayed| option is active, the
+% contents will be passed to the \cmd{\AtBeginDocument} hook.
+%\begin{macro}{\pr@advise}
+% The core macro for modifying commands is \cmd{\pr@advise}. You
+% pass it the original command name as first argument and what should
+% be executed before the saved original command as second argument.
+%\begin{macro}{\pr@advise@ship}
+% The most often used macro for modifying commands is
+% \cmd{\pr@advise@ship}. It receives three arguments. The first is
+% the macro to modify, the second specifies some actions to be done
+% inside of a box to be created before the original macro gets
+% executed, the third one specifies actions after the original macro
+% got executed.
+%\begin{macro}{\pr@loadcfg}
+% The macro \cmd{\pr@loadcfg} is used for loading in configuration
+% files, unless disabled by the |noconfig| option.
+% \begin{macrocode}
+%<*!active>
+\let\preview@delay=\@gobble
+\let\pr@advise=\@gobbletwo
+\long\def\pr@advise@ship#1#2#3{}
+\def\pr@loadcfg#1{\InputIfFileExists{#1.cfg}{}{}}
+\DeclareOption{noconfig}{\let\pr@loadcfg=\@gobble}
+% \end{macrocode}
+%\begin{macro}{\pr@addto@front}
+% This adds code globally to the front of a macro.
+% \begin{macrocode}
+\long\def\pr@addto@front#1#2{%
+ \toks@{#2}\toks@\expandafter{\the\expandafter\toks@#1}%
+ \xdef#1{\the\toks@}}
+% \end{macrocode}
+% \end{macro}
+% These commands get more interesting when |preview| is active:
+% \begin{macrocode}
+\DeclareOption{active}{%
+ \let\ifPreview\iftrue
+ \def\pr@advise#1{%
+ \expandafter\pr@adviseii\csname pr@\string#1\endcsname#1}%
+ \long\def\pr@advise@ship#1#2#3{\pr@advise#1{\pr@protect@ship{#2}{#3}}}%
+ \let\preview@delay\@firstofone}
+% \end{macrocode}
+% \end{macro}
+% \end{macro}
+% \end{macro}
+% \end{macro}
+%
+% \begin{macro}{\pr@adviseii}
+% Now \cmd{\pr@advise} needs its helper macro. In order to avoid
+% recursive definitions, we advise only macros that are not yet
+% advised. Or, more exactly, we throw away the old advice and only
+% take the new one. We use e\TeX's \cmd{\protected} where available
+% for some extra robustness.
+% \begin{macrocode}
+\long\def\pr@adviseii#1#2#3{\preview@delay{%
+ \ifx#1\relax \let#1#2\fi
+ \toks@{#3#1}%
+ \ifx\@undefined\protected \else \protected\fi
+ \long\edef#2{\the\toks@}}}
+% \end{macrocode}
+%\end{macro}
+%
+% The |delayed| option is easy to implement: this is \emph{not} done
+% with \cmd{\let} since at the course of document processing, \LaTeX\
+% redefines \cmd{\AtBeginDocument} and we want to follow that
+% redefinition.
+% \begin{macrocode}
+\DeclareOption{delayed}{%
+ \ifPreview \def\preview@delay{\AtBeginDocument}\fi
+}
+% \end{macrocode}
+%
+%\begin{macro}{\ifpr@fixbb}
+% Another conditional. \cmd{\ifpr@fixbb} tells us whether we want to
+% surround the typeset materials with invisible rules so that Dvips
+% gets the bounding boxes right for, say, pure PostScript inclusions.
+%
+% If you are installing this on an operating system different from
+% the one |preview| has been developed on, you might want to redefine
+% |\pr@markerbox| in your |prdefault.cfg| file to use a file known to
+% be empty, like |/dev/null| is under Unix. Make this redefinition
+% depend on \cmd{\ifpr@fixbb} since only then |\pr@markerbox| will be
+% defined.
+% \begin{macrocode}
+\newif\ifpr@fixbb
+\pr@fixbbfalse
+\DeclareOption{psfixbb}{\ifPreview%
+ \pr@fixbbtrue
+ \newbox\pr@markerbox
+ \setbox\pr@markerbox\hbox{\special{psfile=/dev/null}}\fi
+}
+% \end{macrocode}
+% \end{macro}
+% \begin{macro}{\pr@graphicstype}
+% The |dvips| option redefines the |bop-hook| to reset the page
+% size.
+% \begin{macrocode}
+\let\pr@graphicstype=\z@
+\DeclareOption{dvips}{%
+ \let\pr@graphicstype\@ne
+ \preview@delay{\AtBeginDvi{%
+ \special{!/preview@version(\pr@version)def}
+ \special{!userdict begin/preview-bop-level 0 def%
+ /bop-hook{/preview-bop-level dup load dup 0 le{/isls false def%
+ /vsize 792 def/hsize 612 def}if 1 add store}bind def%
+ /eop-hook{/preview-bop-level dup load dup 0 gt{1 sub}if
+ store}bind def end}}}}
+% \end{macrocode}
+% The |pdftex| option just sets \cmd{\pr@graphicstype}.
+% \begin{macrocode}
+\DeclareOption{pdftex}{%
+ \let\pr@graphicstype\tw@}
+% \end{macrocode}
+% And so does the |xetex| option.
+% \begin{macrocode}
+\DeclareOption{xetex}{%
+ \let\pr@graphicstype\thr@@}
+%</!active>
+% \end{macrocode}
+% \end{macro}
+% \subsection{The internals}
+%
+% Those are only needed if |preview| is active.
+% \begin{macrocode}
+%<*active>
+% \end{macrocode}
+% \begin{macro}{\pr@snippet}
+% \cmd{\pr@snippet} is the current snippet number. We need a
+% separate counter to \cmd{\c@page} since several other commands
+% might fiddle with the page number.
+% \begin{macrocode}
+\newcount\pr@snippet
+\global\pr@snippet=1
+% \end{macrocode}
+% \end{macro}
+% \begin{macro}{\pr@protect}
+% This macro gets one argument which is unpacked and executed in
+% typesetting situations where we are not yet inside of a preview.
+% \begin{macrocode}
+\def\pr@protect{\ifx\protect\@typeset@protect
+ \ifpr@outer \expandafter\expandafter\expandafter
+ \@secondoftwo\fi\fi\@gobble}
+% \end{macrocode}
+% \end{macro}
+% \begin{macro}{\pr@protect@ship}
+% Now for the above mentioned \cmd{\pr@protect@ship}. This gets
+% three arguments. The first is what to do at the beginning of the
+% preview, the second what to do at the end, the third is the macro
+% where we stored the original definition.
+%
+% In case we are not in a typesetting situation,
+% \cmd{\pr@protect@ship} leaves the stored macro to fend for its
+% own. No better or worse protection than the original. And we
+% only do anything different when \cmd{\ifpr@outer} turns out to be
+% true.
+% \begin{macrocode}
+\def\pr@protect@ship{\pr@protect{\@firstoftwo\pr@startbox}%
+ \@gobbletwo}
+% \end{macrocode}
+% \end{macro}
+% \begin{macro}{\pr@insert}
+% \begin{macro}{\pr@mark}
+% \begin{macro}{\pr@marks}
+% We don't want insertions to end up on our lists. So we disable
+% them right now by replacing them with the following:
+% \begin{macrocode}
+\def\pr@insert{\begingroup\afterassignment\pr@insertii\count@}
+\def\pr@insertii{\endgroup\setbox\pr@box\vbox}
+% \end{macrocode}
+% Similar things hold for marks.
+% \begin{macrocode}
+\def\pr@mark{{\afterassignment}\toks@}
+\def\pr@marks{{\aftergroup\pr@mark\afterassignment}\count@}
+% \end{macrocode}
+% \end{macro}
+% \end{macro}
+% \end{macro}
+% \begin{macro}{\pr@box}
+% \begin{macro}{\pr@startbox}
+% Previews will be stored in \cmd{\box}\cmd{\pr@box}.
+% \cmd{\pr@startbox} gets two arguments: code to execute immediately
+% before the following stuff, code to execute afterwards. You have
+% to cater for \cmd{\pr@endbox} being called at the right time
+% yourself. We will use a \cmd{\vsplit} on the box later in order
+% to remove any leading glues, penalties and similar stuff. For
+% this reason we start off the box with an optimal break point.
+% \begin{macrocode}
+\newbox\pr@box
+\long\def\pr@startbox#1#2{%
+ \ifpr@outer
+ \toks@{#2}%
+ \edef\pr@cleanup{\the\toks@}%
+ \setbox\pr@box\vbox\bgroup
+ \break
+ \pr@outerfalse\@arrayparboxrestore
+ \let\insert\pr@insert
+ \let\mark\pr@mark
+ \let\marks\pr@marks
+ \expandafter\expandafter\expandafter
+ \pr@ship@start
+ \expandafter\@firstofone
+ \else
+ \expandafter \@gobble
+ \fi{#1}}
+% \end{macrocode}
+% \end{macro}
+% \end{macro}
+% \begin{macro}{\pr@endbox}
+% Cleaning up also is straightforward. If we have to watch the
+% bounding \TeX\ box, we want to remove spurious skips. We also
+% want to unwrap a possible single line paragraph, so that the box
+% is not full line length. We use \cmd{\vsplit} to clean up leading
+% glue and stuff, and we make some attempt of removing trailing
+% ones. After that, we wrap up the box including possible material
+% from \cmd{\AtBeginDvi}. If the |psfixbb| option is active, we
+% adorn the upper left and lower right corners with copies of
+% \cmd{\pr@markerbox}. The first few lines cater for \LaTeX\ hiding
+% things like like the code for \cmd{\paragraph} in \cmd{\everypar}.
+% \begin{macrocode}
+\def\pr@endbox{%
+ \let\reserved@a\relax
+ \ifvmode \edef\reserved@a{\the\everypar}%
+ \ifx\reserved@a\@empty\else
+ \dimen@\prevdepth
+ \noindent\par
+ \setbox\z@\lastbox\unskip\unpenalty
+ \prevdepth\dimen@
+ \setbox\z@\hbox\bgroup\penalty-\maxdimen\unhbox\z@
+ \ifnum\lastpenalty=-\maxdimen\egroup
+ \else\egroup\box\z@ \fi\fi\fi
+ \ifhmode \par\unskip\setbox\z@\lastbox
+ \nointerlineskip\hbox{\unhbox\z@\/}%
+ \else \unskip\unpenalty\unskip \fi
+ \egroup
+ \setbox\pr@box\vbox{%
+ \baselineskip\z@skip \lineskip\z@skip \lineskiplimit\z@
+ \@begindvi
+ \nointerlineskip
+ \splittopskip\z@skip\setbox\z@\vsplit\pr@box to\z@
+ \unvbox\z@
+ \nointerlineskip
+ %\color@setgroup
+ \box\pr@box
+ %\color@endgroup
+ }%
+% \end{macrocode}
+% \begin{macro}{\pr@ship@end}
+% \label{sec:prshipend}At this point, \cmd{\pr@ship@end} gets
+% called. You must not under any circumstances change |\box\pr@box|
+% in any way that would add typeset material at the front of it,
+% except for PostScript header specials, since the front of
+% |\box\pr@box| may contain stuff from \cmd{\AtBeginDvi}.
+% \cmd{\pr@ship@end} contains two types of code additions: stuff
+% that adds to |\box\pr@box|, like the |labels| option does, and
+% stuff that measures out things or otherwise takes a look at the
+% finished |\box\pr@box|, like the |auctex| or |showbox| option do.
+% The former should use \cmd{pr@addto@front} for adding to this
+% hook, the latter use \cmd{g@addto@macro} for adding at the end of
+% this hook.
+%
+% Note that we shift the output box up by its height via
+% \cmd{\voffset}. This has three reasons: first we make sure that
+% no package-inflicted non-zero value of \cmd{\voffset} or
+% \cmd{\hoffset} will have any influence on the positioning of our
+% box. Second we shift the box such that its basepoint will exactly
+% be at the (1in,1in)~mark defined by \TeX. That way we can
+% properly take ascenders into account. And the third reason is
+% that \TeX\ treats a \cmd{\hbox} and a \cmd{\vbox} differently with
+% regard to the treating of its depth. Shifting \cmd{\voffset} and
+% \cmd{\hoffset} can be inhibited by setting |\pr@offset@override|.
+% \begin{macrocode}
+ \pr@ship@end
+ {\let\protect\noexpand
+ \ifx\pr@offset@override\@undefined
+ \voffset=-\ht\pr@box
+ \hoffset=\z@
+ \fi
+ \c@page=\pr@snippet
+ \pr@shipout
+ \ifpr@fixbb\hbox{%
+ \dimen@\wd\pr@box
+ \@tempdima\ht\pr@box
+ \@tempdimb\dp\pr@box
+ \box\pr@box
+ \llap{\raise\@tempdima\copy\pr@markerbox\kern\dimen@}%
+ \lower\@tempdimb\copy\pr@markerbox}%
+ \else \box\pr@box \fi}%
+ \global\advance\pr@snippet\@ne
+ \pr@cleanup
+}
+% \end{macrocode}
+% \end{macro}
+% \end{macro}
+% Oh, and we kill off the usual meaning of \cmd{\shipout} in case
+% somebody makes a special output routine. The following test is
+% pretty much the same as in |everyshi.sty|. One of its implications
+% is that if someone does a \cmd{\shipout} of a \emph{void} box,
+% things will go horribly wrong.
+% \begin{macro}{\shipout}
+% \begin{macrocode}
+\let\pr@shipout=\shipout
+\def\shipout{\deadcycles\z@\bgroup\setbox\z@\box\voidb@x
+ \afterassignment\pr@shipoutegroup\setbox\z@}
+\def\pr@shipoutegroup{\ifvoid\z@ \expandafter\aftergroup\fi \egroup}
+% \end{macrocode}
+% \end{macro}
+% \subsection{Parsing commands}
+% \begin{macro}{\pr@parseit}
+% \begin{macro}{\pr@endparse}
+% \begin{macro}{\pr@callafter}
+% The following stuff is for parsing the arguments of commands we
+% want to somehow surround with stuff. Usage is
+% \begin{quote}
+% \cmd{\pr@callafter}\meta{aftertoken}\meta{parsestring}\cmd{\pr@endparse}\\
+% \qquad\meta{macro}\meta{parameters}
+% \end{quote}
+% \meta{aftertoken} is stored away and gets executed once parsing
+% completes, with its first argument being the parsed material.
+% \meta{parsestring} would be, for example for the
+% \cmd{\includegraphics} macro, |*[[!|, an optional |*| argument
+% followed by two optional arguments enclosed in |[]|, followed by
+% one mandatory argument.
+%
+% For the sake of a somewhat more intuitive syntax, we now support
+% also the syntax |{*[]{}}| in the optional argument. Since \TeX\
+% strips redundant braces, we have to write |[{{}}]| in this syntax
+% for a single mandatory argument. Hard to avoid. We use an
+% unusual character for ending the parsing. The implementation is
+% rather trivial.
+% \begin{macrocode}
+\def\pr@parseit#1{\csname pr@parse#1\endcsname}
+\let\pr@endparse=\@percentchar
+\def\next#1{%
+\def\pr@callafter{%
+ \afterassignment\pr@parseit
+ \let#1= }}
+\expandafter\next\csname pr@parse\pr@endparse\endcsname
+% \end{macrocode}
+% \end{macro}
+% \end{macro}
+% \end{macro}
+% \begin{macro}{\pr@parse*}
+% Straightforward, same mechanism \LaTeX\ itself employs. We take
+% some care not to pass potential |#| tokens unprotected through
+% macros.
+% \begin{macrocode}
+\long\expandafter\def\csname pr@parse*\endcsname#1\pr@endparse#2{%
+ \begingroup\toks@{#1\pr@endparse{#2}}%
+ \edef\next##1{\endgroup##1\the\toks@}%
+ \@ifstar{\next{\pr@parse@*}}{\next\pr@parseit}}
+% \end{macrocode}
+% \end{macro}
+% \begin{macro}{\pr@parse[}
+% \begin{macro}{\pr@brace}
+% Copies optional parameters in brackets if present. The additional
+% level of braces is necessary to ensure that braces the user might
+% have put to hide a~|]| bracket in an optional argument don't get
+% lost. There will be no harm if such braces were not there at the
+% start.
+% \begin{macrocode}
+\long\expandafter\def\csname pr@parse[\endcsname#1\pr@endparse#2{%
+ \begingroup\toks@{#1\pr@endparse{#2}}%
+ \edef\next##1{\endgroup##1\the\toks@}%
+ \@ifnextchar[{\next\pr@bracket}{\next\pr@parseit}}
+\long\def\pr@bracket#1\pr@endparse#2[#3]{%
+ \pr@parseit#1\pr@endparse{#2[{#3}]}}
+% \end{macrocode}
+% \end{macro}
+% \end{macro}
+% \begin{macro}{\pr@parse]}
+% This is basically a do-nothing, so that we may use the syntax
+% |{*[][]!}| in the optional argument instead of the more concise
+% but ugly |*[[!| which confuses the brace matchers of editors.
+% \begin{macrocode}
+\expandafter\let\csname pr@parse]\endcsname=\pr@parseit
+% \end{macrocode}
+% \end{macro}
+% \begin{macro}{\pr@parse}
+% \begin{macro}{\pr@parse!}
+% Mandatory arguments are perhaps easiest to parse.
+% \begin{macrocode}
+\long\def\pr@parse#1\pr@endparse#2#3{%
+ \pr@parseit#1\pr@endparse{#2{#3}}}
+\expandafter\let\csname pr@parse!\endcsname=\pr@parse
+% \end{macrocode}
+% \end{macro}
+% \end{macro}
+% \begin{macro}{\pr@parse?}
+% \begin{macro}{\pr@parsecond}
+% This does an explicit call of |\@ifnextchar| and forks into the
+% given two alternatives as a result.
+% \begin{macrocode}
+\long\expandafter\def\csname pr@parse?\endcsname#1#2\pr@endparse#3{%
+ \begingroup\toks@{#2\pr@endparse{#3}}%
+ \@ifnextchar#1{\pr@parsecond\@firstoftwo}%
+ {\pr@parsecond\@secondoftwo}}
+\def\pr@parsecond#1{\expandafter\endgroup
+ \expandafter\expandafter\expandafter\pr@parseit
+ \expandafter#1\the\toks@}
+% \end{macrocode}
+% \end{macro}
+% \end{macro}
+% \begin{macro}{\pr@parse@}
+% This makes it possible to insert literal material into the
+% argument list.
+% \begin{macrocode}
+ \long\def\pr@parse@#1#2\pr@endparse#3{%
+ \pr@parseit #2\pr@endparse{#3#1}}
+% \end{macrocode}
+% \end{macro}
+% \begin{macro}{\pr@parse-}
+% This will just drop the next token.
+% \begin{macrocode}
+\long\expandafter\def\csname pr@parse-\endcsname
+ #1\pr@endparse#2{\begingroup
+ \toks@{\endgroup\pr@parseit #1\pr@endparse{#2}}%
+ {\aftergroup\the\aftergroup\toks@ \afterassignment}%
+ \let\next= }
+% \end{macrocode}
+% \end{macro}
+% \begin{macro}{\pr@parse:}
+% The following is a transform rule. A macro is being defined with
+% the given argument list and replacement, and the transformed
+% version replaces the original. The result of the transform is
+% still subject to being parsed.
+% \begin{macrocode}
+\long\expandafter\def\csname pr@parse:\endcsname
+ #1#2#3\pr@endparse#4{\begingroup
+ \toks@{\endgroup \pr@parseit#3\pr@endparse{#4}}%
+ \long\def\next#1{#2}%
+ \the\expandafter\toks@\next}
+% \end{macrocode}
+% \end{macro}
+% \edef\next{\noexpand\begin{macro}{\noexpand
+% \pr@parse\string#}}
+% \next
+% Another transform rule, but this passes the transformed material
+% into the token list.
+% \begin{macrocode}
+\long\expandafter\def\csname pr@parse#\endcsname
+ #1#2#3\pr@endparse#4{\begingroup
+ \toks@{#4}%
+ \long\edef\next##1{\toks@{\the\toks@##1}}%
+ \toks@{\endgroup \pr@parseit#3\pr@endparse}%
+ \long\def\reserved@a#1{{#2}}%
+ \the\expandafter\next\reserved@a}
+%</active>
+% \end{macrocode}
+% \end{macro}
+%
+% \subsection{Selection options}
+% The |displaymath| option. The |equation| environments in AMS\LaTeX\
+% already do too much before our hook gets to interfere, so we hook
+% earlier. Some juggling is involved to ensure we get the original
+% |\everydisplay| tokens only once and where appropriate.
+%
+% The incredible hack with |\dt@ptrue| is necessary for working around
+% bug `amslatex/3425'.
+% \begin{macrocode}
+%<*!active>
+\begingroup
+\catcode`\*=11
+\@firstofone{\endgroup
+\DeclareOption{displaymath}{%
+ \preview@delay{\toks@{%
+ \pr@startbox{\noindent$$%
+ \aftergroup\pr@endbox\@gobbletwo}{$$}\@firstofone}%
+ \everydisplay\expandafter{\the\expandafter\toks@
+ \expandafter{\the\everydisplay}}}%
+ \pr@advise@ship\equation{\begingroup\aftergroup\pr@endbox
+ \def\dt@ptrue{\m@ne=\m@ne}\noindent}%
+ {\endgroup}%
+ \pr@advise@ship\equation*{\begingroup\aftergroup\pr@endbox
+ \def\dt@ptrue{\m@ne=\m@ne}\noindent}%
+ {\endgroup}%
+ \PreviewOpen[][\def\dt@ptrue{\m@ne=\m@ne}\noindent#1]\[%
+ \PreviewClose\]%
+ \PreviewEnvironment[][\noindent#1]{eqnarray}%
+ \PreviewEnvironment[][\noindent#1]{eqnarray*}%
+ \PreviewEnvironment{displaymath}%
+}}
+% \end{macrocode}
+%
+% The |textmath| option. Some folderol in order to define the active
+% |$|
+% math mode delimiter. \cmd\pr@textmathcheck is used for checking
+% whether we have a single |$| or double |$$|.
+% In the latter case, we enter display math (this sort of display math
+% is not allowed inside of \LaTeX\ because of inconsistent spacing,
+% but surprisingly many people use it nevertheless). Strictly
+% speaking, this is incorrect, since not every
+% |$$| actually means display math. For example, |\hbox{$$}| will
+% because of restricted horizontal mode rather yield an empty text
+% math formula. Since our implementation moved the sequence inside of
+% a |\vbox|, the interpretation will change. People should just not
+% enter rubbish like that.
+% \begin{macrocode}
+\begingroup
+\def\next#1#2{%
+ \endgroup
+ \DeclareOption{textmath}{%
+ \PreviewEnvironment{math}%
+ \preview@delay{\ifx#1\@undefined \let#1=$%$
+ \fi\catcode`\$=\active
+ \ifx\xyreuncatcodes\@undefined\else
+ \edef\next{\catcode`@=\the\catcode`@\relax}%
+ \makeatother\expandafter\xyreuncatcodes\next\fi}%
+ \pr@advise@ship\(\pr@endaftergroup{}% \)
+ \pr@advise@ship#1{\@firstoftwo{\let#1=#2%
+ \futurelet\reserved@a\pr@textmathcheck}}{}}%
+ \def\pr@textmathcheck{\expandafter\pr@endaftergroup
+ \ifx\reserved@a#1{#2#2}\expandafter\@gobbletwo\fi#2}}
+\lccode`\~=`\$
+\lowercase{\expandafter\next\expandafter~}%
+ \csname pr@\string$%$
+ \endcsname
+%</!active>
+% \end{macrocode}
+% \begin{macro}{\pr@endaftergroup}
+% This justs ends the box after the group opened by |#1| is closed
+% again.
+% \begin{macrocode}
+%<*active>
+\def\pr@endaftergroup#1{#1\aftergroup\pr@endbox}
+%</active>
+% \end{macrocode}
+% \end{macro}
+%
+% The |graphics| option.
+% \begin{macrocode}
+%<*!active>
+\DeclareOption{graphics}{%
+ \PreviewMacro[*[[!]{\includegraphics}%]]
+}
+% \end{macrocode}
+% The |floats| option. The complications here are merely to spare us
+% bug reports about broken document classes that use |\let| on
+% |\endfigure| and similar. Notable culprits that have not been
+% changed in years in spite of reports are |elsart.cls| and
+% |IEEEtran.cls|. Complain when you are concerned.
+% \begin{macrocode}
+\def\pr@floatfix#1#2{\ifx#1#2%
+ \ifx#1\@undefined\else
+ \PackageWarningNoLine{preview}{%
+Your document class has a bad definition^^J
+of \string#1, most likely^^J
+\string\let\string#1=\string#2^^J
+which has now been changed to^^J
+\string\def\string#1{\string#2}^^J
+because otherwise subsequent changes to \string#2^^J
+(like done by several packages changing float behaviour)^^J
+can't take effect on \string#1.^^J
+Please complain to your document class author}%
+ \def#1{#2}\fi\fi}
+\begingroup
+\def\next#1#2{\endgroup
+ \DeclareOption{floats}{%
+ \pr@floatfix\endfigure\end@float
+ \pr@floatfix\endtable\end@float
+ \pr@floatfix#1\end@dblfloat
+ \pr@floatfix#2\end@dblfloat
+ \PreviewSnarfEnvironment[![]{@float}%]
+ \PreviewSnarfEnvironment[![]{@dblfloat}%]
+ }}
+\expandafter\next\csname endfigure*\expandafter\endcsname
+ \csname endtable*\endcsname
+% \end{macrocode}
+% The |sections| option. Two optional parameters might occur in
+% |memoir.cls|.
+% \begin{macrocode}
+\DeclareOption{sections}{%
+ \PreviewMacro[!!!!!!*[[!]{\@startsection}%]]
+ \PreviewMacro[*[[!]{\chapter}%]]
+}
+% \end{macrocode}
+% We now interpret any further options as driver files we load. Note
+% that these driver files are loaded even when |preview| is not
+% active. The reason is that they might define commands (like
+% \cmd{\PreviewCommand}) that should be available even in case of an
+% inactive package. Large parts of the |preview| package will not
+% have been loaded in this case: you have to cater for that.
+% \begin{macrocode}
+\DeclareOption*
+ {\InputIfFileExists{pr\CurrentOption.def}{}{\OptionNotUsed}}
+% \end{macrocode}
+%
+% \subsection{Preview attaching commands}
+% \begin{macro}{\PreviewMacro}
+% As explained above. Detect possible |*| and call appropriate
+% macro.
+% \begin{macrocode}
+\def\PreviewMacro{\@ifstar\pr@starmacro\pr@macro}
+% \end{macrocode}
+% The version without |*| is now rather straightforward.
+% \begin{macro}{\pr@macro}
+% \begin{macro}{\pr@domacro}
+% \begin{macro}{\pr@macroii}
+% \begin{macro}{\pr@endmacro}
+% \begin{macrocode}
+\long\def\pr@domacro#1#2{%
+ \long\def\next##1{#2}%
+ \pr@callafter\next#1]\pr@endparse}
+\newcommand\pr@macro[1][]{%
+ \toks@{\pr@domacro{#1}}%
+ \long\edef\next[##1]##2{%
+ \noexpand\pr@advise@ship{##2}{\the\toks@{##1\noexpand\pr@endbox}}{}}%
+ \@ifnextchar[\next\pr@macroii}
+\def\pr@macroii{\next[##1]}
+\long\def\pr@endmacro#1{#1\pr@endbox}
+% \end{macrocode}
+% \end{macro}
+% \end{macro}
+% \end{macro}
+% \end{macro}
+% \end{macro}
+% \begin{macro}{PreviewMacro*}
+% \begin{macro}{\pr@protect@domacro}
+% \begin{macro}{\pr@starmacro}
+% The version with |*| has to parse the arguments, then throw them
+% away. Some internal macros first, then the interface call.
+% \begin{macrocode}
+\long\def\pr@protect@domacro#1#2{\pr@protect{%
+ \long\def\next##1{#2}%
+ \pr@callafter\next#1]\pr@endparse}}
+\newcommand\pr@starmacro[1][]{\toks@{\pr@protect@domacro{#1}}%
+ \long\edef\next[##1]##2{%
+ \noexpand\pr@advise##2{\the\toks@{##1}}}%
+ \@ifnextchar[\next{\next[]}}
+% \end{macrocode}
+% \end{macro}
+% \end{macro}
+% \end{macro}
+% \begin{macro}{\PreviewOpen}
+% As explained above. Detect possible |*| and call appropriate macro.
+% \begin{macrocode}
+\def\PreviewOpen{\@ifstar\pr@starmacro\pr@open}
+% \end{macrocode}
+% The version without |*| is now rather straightforward.
+% \begin{macro}{\pr@open}
+% \begin{macrocode}
+\newcommand\pr@open[1][]{%
+ \toks@{\pr@domacro{#1}}%
+ \long\edef\next[##1]##2{%
+ \noexpand\pr@advise##2{\begingroup
+ \noexpand\pr@protect@ship
+ {\the\toks@{\begingroup\aftergroup\noexpand\pr@endbox##1}}%
+ {\endgroup}}}%
+ \@ifnextchar[\next\pr@macroii}
+% \end{macrocode}
+% \end{macro}
+% \end{macro}
+% \begin{macro}{\PreviewClose}
+% As explained above. Detect possible |*| and call appropriate
+% macro.
+% \begin{macrocode}
+\def\PreviewClose{\@ifstar\pr@starmacro\pr@close}
+% \end{macrocode}
+% The version without |*| is now rather straightforward.
+% \begin{macro}{\pr@close}
+% \begin{macrocode}
+\newcommand\pr@close[1][]{%
+ \toks@{\pr@domacro{#1}}%
+ \long\edef\next[##1]##2{%
+ \noexpand\pr@advise{##2}{\the\toks@{##1\endgroup}}}%
+ \@ifnextchar[\next\pr@macroii}
+% \end{macrocode}
+% \end{macro}
+% \end{macro}
+% \begin{macro}{\PreviewEnvironment}
+% Actually, this ignores any syntax argument. But don't tell
+% anybody. Except for the |*|~variant, it respects (actually
+% ignores) any argument! Of course, we'll need to deactivate
+% |\end{|\meta{environment}|}| as well.
+% \begin{macrocode}
+\def\PreviewEnvironment{\@ifstar\pr@starenv\pr@env}
+\newcommand\pr@starenv[1][]{\toks@{\pr@starmacro[{#1}]}%
+ \long\edef\next##1##2{%
+ \the\toks@[{##2}]##1}%
+ \begingroup\pr@starenvii}
+\newcommand\pr@starenvii[2][]{\endgroup
+ \expandafter\next\csname#2\endcsname{#1}%
+ \expandafter\pr@starmacro\csname end#2\endcsname}
+\newcommand\pr@env[1][]{%
+ \toks@{\pr@domacro{#1}}%
+ \long\edef\next[##1]##2{%
+ \noexpand\expandafter\noexpand\pr@advise@ship
+ \noexpand\csname##2\noexpand\endcsname{\the\toks@
+ {\begingroup\aftergroup\noexpand\pr@endbox##1}}{\endgroup}}%
+ \@ifnextchar[\next\pr@macroii %]
+ }
+% \end{macrocode}
+% \end{macro}
+% \begin{macro}{\PreviewSnarfEnvironment}
+% This is a nuisance since we have to advise \emph{both} the
+% environment and its end.
+% \begin{macrocode}
+\newcommand{\PreviewSnarfEnvironment}[2][]{%
+ \expandafter\pr@advise
+ \csname #2\endcsname{\pr@snarfafter{#1}}%
+ \expandafter\pr@advise
+ \csname end#2\endcsname{\pr@endsnarf}}
+%</!active>
+% \end{macrocode}
+% \end{macro}
+% \begin{macro}{\pr@snarfafter}
+% \begin{macro}{\pr@startsnarf}
+% \begin{macro}{\pr@endsnarf}
+% Ok, this looks complicated, but we have to start a group in order
+% to be able to hook \cmd{\pr@endbox} into the game only when
+% \cmd{\ifpr@outer} has triggered the start. And we need to get our
+% start messages out before parsing the arguments.
+% \begin{macrocode}
+%<*active>
+\let\pr@endsnarf\relax
+\long\def\pr@snarfafter#1{\ifpr@outer
+ \pr@ship@start
+ \let\pr@ship@start\relax
+ \let\pr@endsnarf\endgroup
+ \else
+ \let\pr@endsnarf\relax
+ \fi
+ \pr@protect{\pr@callafter\pr@startsnarf#1]\pr@endparse}}
+\def\pr@startsnarf#1{#1\begingroup
+ \pr@startbox{\begingroup\aftergroup\pr@endbox}{\endgroup}%
+ \ignorespaces}
+%</active>
+% \end{macrocode}
+% \end{macro}
+% \end{macro}
+% \end{macro}
+% \begin{macro}{\pr@ship@start}
+% \begin{macro}{\pr@ship@end}
+% The hooks \cmd{\pr@ship@start} and \cmd{\pr@ship@end} can be added
+% to by option files by the help of the \cmd{\g@addto@macro} command
+% from \LaTeX, and by the \cmd{\pr@addto@front} command from
+% |preview.sty| itself. They are called just before starting to
+% process some preview, and just after it. Here is the policy for
+% adding to them: \cmd{\pr@ship@start} is called inside of the vbox
+% |\pr@box| before typeset material gets produced. It is, however,
+% preceded by a break command that is intended for usage in
+% \cmd{\vsplit}, so that any following glue might disappear. In
+% case you want to add any material on the list, you have to precede
+% it with \cmd{\unpenalty} and have to follow it with \cmd{\break}.
+% You have make sure that under no circumstances any other legal
+% breakpoints appear before that, and your material should
+% contribute no nonzero dimensions to the page. For the policies of
+% the \cmd{\pr@ship@end} hook, see the description on
+% page~\pageref{sec:prshipend}.
+% \begin{macrocode}
+%<*!active>
+\let\pr@ship@start\@empty
+\let\pr@ship@end\@empty
+% \end{macrocode}
+% \end{macro}
+% \end{macro}
+% \begin{environment}{preview}
+% \begin{environment}{nopreview}
+% First we write the definitions of these environments when
+% |preview| is inactive. We will redefine them if |preview| gets
+% activated.
+% \begin{macrocode}
+\newenvironment{preview}{\ignorespaces}{\ifhmode\unskip\fi}
+\newenvironment{nopreview}{\ignorespaces}{\ifhmode\unskip\fi}
+% \end{macrocode}
+% \end{environment}
+% \end{environment}
+%
+% We now process the options and finish in case we are not active.
+% \begin{macrocode}
+\ProcessOptions\relax
+\ifPreview\else\expandafter\endinput\fi
+%</!active>
+% \end{macrocode}
+% Now for the redefinition of the |preview| and |endpreview|
+% environments:
+% \begin{macrocode}
+%<*active>
+\renewenvironment{preview}{\begingroup
+ \pr@startbox{\begingroup\aftergroup\pr@endbox}%
+ {\endgroup}%
+ \ignorespaces}%
+ {\ifhmode\unskip\fi\endgroup}
+\renewenvironment{nopreview}{\pr@outerfalse\ignorespaces}%
+ {\ifhmode\unskip\fi}
+% \end{macrocode}
+% We use the normal output routine, but hijack it a bit for our
+% purposes to preserve \cmd{\AtBeginDvi} hooks and not get previews
+% while in output: that could become rather ugly.
+%
+% The main work of disabling normal output relies on a \cmd{\shipout}
+% redefinition.
+% \begin{macro}{\pr@output}
+% \begin{macrocode}
+\newtoks\pr@output
+\pr@output\output
+\output{%
+ \pr@outerfalse
+ \let\@begindvi\@empty
+ \the\pr@output}
+\let\output\pr@output
+% \end{macrocode}
+% \end{macro}
+% \begin{macro}{\pr@typeinfos}
+% Then we have some document info that style files might want to
+% output.
+% \begin{macrocode}
+\def\pr@typeinfos{\typeout{Preview: Fontsize \f@size pt}%
+ \ifnum\mag=\@m\else\typeout{Preview: Magnification \number\mag}\fi
+ \ifx\pdfoutput\@undefined
+ \ifx\XeTeXversion\@undefined \else
+ % FIXME: The message should not be emitted if XeTeX does not produce
+ % PDF. There does not seem to be a primitive for that, though.
+ \typeout{Preview: PDFoutput 1}%
+ \fi
+ \else
+ \ifx\pdfoutput\relax \else
+ \ifnum\pdfoutput>\z@
+ \typeout{Preview: PDFoutput 1}%
+ \fi
+ \fi
+ \fi
+}
+\AtBeginDocument{\pr@typeinfos}
+% \end{macrocode}
+% \end{macro}
+% And at the end we load the default configuration file, so that it
+% may override settings from this package:
+% \begin{macrocode}
+\pr@loadcfg{prdefault}
+%</active>
+%</style>
+% \end{macrocode}
+%
+% \section{The option files}
+% \subsection{The \texttt{auctex} option}
+% The AUC\TeX\ option will cause error messages to spew. We want them
+% on the terminal, but we don't want \LaTeX\ to stop its automated
+% run. We delay \cmd{\nonstopmode} in case the user has any
+% pseudo-interactive folderol like reading in of file names in his
+% preamble. Because we are so good-hearted, we will not break this as
+% long as the document has not started, but after that we need the
+% error message mechanism operative.
+%
+% The |\nofiles| command here tries to avoid clobbering input files
+% used for references and similar. It will come too late if you call
+% the package with \cmd{\AtBeginDocument}, so you'll need to issue
+% |\nofiles| yourself in that case. Previously, this was done
+% unconditionally in the main style file, but since we don't know what
+% the package may be used for, this was inappropriate.
+%
+% So here is the contents of the |prauctex.def| file:
+% \begin{macrocode}
+%<auctex>\ifPreview\else\expandafter\endinput\fi
+%<auctex>\nofiles
+%<auctex>\preview@delay{\nonstopmode}
+% \end{macrocode}
+% Ok, here comes creative error message formatting. It turns out a
+% sizable portion of the runtime is spent in I/O. Making the error
+% messages short is an advantage. It is not possible to convince
+% \TeX\ to make shorter error messages than this: \TeX\ always wants
+% to include context. This is about the shortest \ae sthetic one we
+% can muster.
+% \begin{macrocode}
+%<auctex>\begingroup
+%<auctex>\lccode`\~=`\-
+%<auctex>\lccode`\{=`\<
+%<auctex>\lccode`\}=`\>
+%<auctex>\lowercase{\endgroup
+%<auctex> \def\pr@msgi{{~}}}
+%<auctex>\def\pr@msgii{Preview:
+%<auctex> Snippet \number\pr@snippet\space}
+%<auctex>\begingroup
+%<auctex>\catcode`\-=13
+%<auctex>\catcode`\<=13
+%<auctex>\@firstofone{\endgroup
+%<auctex>\def\pr@msg#1{{%
+%<auctex> \let<\pr@msgi
+%<auctex> \def-{\pr@msgii#1}%
+%<auctex> \errhelp{Not a real error.}%
+%<auctex> \errmessage<}}}
+%<auctex>\g@addto@macro\pr@ship@start{\pr@msg{started}}
+%<auctex>\g@addto@macro\pr@ship@end{\pr@msg{ended.%
+%<auctex> (\number\ht\pr@box+\number\dp\pr@box x\number\wd\pr@box)}}
+% \end{macrocode}
+% This looks pretty baffling, but it produces something short and
+% semi-graphical, namely |<-><->|. That is a macro |<| that expands
+% into |<->|, where |<| and |>| are the braces around an
+% \cmd{\errmessage} argument and |-| is a macro expanding to the full
+% text of the error message. Cough cough. You did not really want to
+% know, did you?
+%
+% Since over/underfull boxes are about the messiest things to parse,
+% we disable them by setting the appropriate badness limits and making
+% the variables point to junk. We also disable other stuff. While we
+% set \cmd{\showboxbreadth} and \cmd{\showboxdepth} to indicate as
+% little diagnostic output as possible, we keep them operative, so
+% that the user retains the option of debugging using this stuff. The
+% other variables concerning the generation of warnings and
+% daignostics, however, are more often set by commonly employed
+% packages and macros such as \cmd{\sloppy}. So we kill them off for
+% good.
+% \begin{macrocode}
+%<auctex>\hbadness=\maxdimen
+%<auctex>\newcount\hbadness
+%<auctex>\vbadness=\maxdimen
+%<auctex>\let\vbadness=\hbadness
+%<auctex>\hfuzz=\maxdimen
+%<auctex>\newdimen\hfuzz
+%<auctex>\vfuzz=\maxdimen
+%<auctex>\let\vfuzz=\hfuzz
+%<auctex>\showboxdepth=-1
+%<auctex>\showboxbreadth=-1
+% \end{macrocode}
+% Ok, now we load a possible configuration file.
+% \begin{macrocode}
+%<auctex>\pr@loadcfg{prauctex}
+% \end{macrocode}
+% And here we cater for several frequently used commands in
+% |prauctex.cfg|:
+% \begin{macrocode}
+%<auccfg>\PreviewMacro*[[][#1{}]\footnote
+%<auccfg>\PreviewMacro*[?[{@{[]}}{}][#1]\item
+%<auccfg>\PreviewMacro*\emph
+%<auccfg>\PreviewMacro*\textrm
+%<auccfg>\PreviewMacro*\textit
+%<auccfg>\PreviewMacro*\textsc
+%<auccfg>\PreviewMacro*\textsf
+%<auccfg>\PreviewMacro*\textsl
+%<auccfg>\PreviewMacro*\texttt
+%<auccfg>\PreviewMacro*\textcolor
+%<auccfg>\PreviewMacro*\mbox
+%<auccfg>\PreviewMacro*[][#1{}]\author
+%<auccfg>\PreviewMacro*[][#1{}]\title
+%<auccfg>\PreviewMacro*\and
+%<auccfg>\PreviewMacro*\thanks
+%<auccfg>\PreviewMacro*[][#1{}]\caption
+%<auccfg>\preview@delay{\@ifundefined{pr@\string\@startsection}{%
+%<auccfg> \PreviewMacro*[!!!!!!*][#1{}]\@startsection}{}}
+%<auccfg>\preview@delay{\@ifundefined{pr@\string\chapter}{%
+%<auccfg> \PreviewMacro*[*][#1{}]\chapter}{}}
+%<auccfg>\PreviewMacro*\index
+% \end{macrocode}
+%
+% \subsection{The \texttt{lyx} option}
+% The following is the option providing LyX with info for its preview
+% implementation.
+% \begin{macrocode}
+%<lyx>\ifPreview\else\expandafter\endinput\fi
+%<lyx>\pr@loadcfg{prlyx}
+%<lyx>\g@addto@macro\pr@ship@end{\typeout{Preview:
+%<lyx> Snippet \number\pr@snippet\space
+%<lyx> \number\ht\pr@box\space \number\dp\pr@box \space\number\wd\pr@box}}
+% \end{macrocode}
+%
+% \subsection{The \texttt{counters} option}
+% This outputs a checkpoint. We do this by saving all counter
+% registers in backup macros starting with |\pr@c@| in their name. A
+% checkpoint first writes out all changed counters (previously
+% unchecked counters are not written out unless different from zero),
+% then saves all involved counter values. \LaTeX\ tracks its counters
+% in the global variable \cmd{\cl@ckpt}.
+% \begin{macrocode}
+%<counters>\ifPreview\else\expandafter\endinput\fi
+%<counters>\def\pr@eltprint#1{\expandafter\@gobble\ifnum\value{#1}=0%
+%<counters> \csname pr@c@#1\endcsname\else\relax
+%<counters> \space{#1}{\arabic{#1}}\fi}
+%<counters>\def\pr@eltdef#1{\expandafter\xdef
+%<counters> \csname pr@c@#1\endcsname{\arabic{#1}}}
+%<counters>\def\pr@ckpt#1{{\let\@elt\pr@eltprint\edef\next{\cl@@ckpt}%
+%<counters> \ifx\next\@empty\else\typeout{Preview: Counters\next#1}%
+%<counters> \let\@elt\pr@eltdef\cl@@ckpt\fi}}
+%<counters>\pr@addto@front\pr@ship@start{\pr@ckpt:}
+%<counters>\pr@addto@front\pr@ship@end{\pr@ckpt.}
+% \end{macrocode}
+%
+% \subsection{Debugging options}
+% Those are for debugging the operation of |preview|, and thus are
+% mostly of interest for people that want to use |preview| for their
+% own purposes. Since debugging output is potentially confusing to
+% the error message parsing from AUC\TeX, you should not turn on
+% |\tracingonline| or switch from |\nonstopmode| unless you are
+% certain your package will never be used with \previewlatex.
+%
+% \paragraph{The \texttt{showbox} option} will generate diagnostic
+% output for every produced box. It does not delay the resetting of
+% the |\showboxbreadth| and |\showboxdepth| parameters so that you can
+% still change them after the loading of the package. It does,
+% however, move them to the end of the package loading, so that they
+% will not be affected by the |auctex| option.
+% \begin{macrocode}
+%<showbox>\ifPreview\else\expandafter\endinput\fi
+%<showbox>\AtEndOfPackage{%
+%<showbox> \showboxbreadth\maxdimen
+%<showbox> \showboxdepth\maxdimen}
+%<showbox>\g@addto@macro\pr@ship@end{\showbox\pr@box}
+% \end{macrocode}
+%
+% \paragraph{The \texttt{tracingall} option} is for the really heavy
+% diagnostic stuff. For the reasons mentioned above, we do not want
+% to change the setting of the interaction mode, nor of the
+% |tracingonline| flag. If the user wants them different, he should
+% set them outside of the preview boxes.
+% \begin{macrocode}
+%<tracingall>\ifPreview\else\expandafter\endinput\fi
+%<tracingall>\pr@addto@front\pr@ship@start{\let\tracingonline\count@
+%<tracingall> \let\errorstopmode\@empty\tracingall}
+% \end{macrocode}
+%
+% \subsection{Supporting conversions}
+% It is not uncommon to want to use the results of |preview| as
+% images. One possibility is to generate a flurry of EPS files with
+% \begin{quote}
+% |dvips -E -i -Ppdf -o| \meta{outputfile}|.000| \meta{inputfile}
+% \end{quote}
+% However, in case those are to be processed further into graphic
+% image files by Ghostscript, this process is inefficient. One cannot
+% use Ghostscript in a single run for generating the files, however,
+% since one needs to set the page size (or full size pages will be
+% produced). The |tightpage| option will set the page dimensions at
+% the start of each PostScript page so that the output will be sized
+% appropriately. That way, a single pass of Dvips followed by a
+% single pass of Ghostscript will be sufficient for generating all
+% images.
+%
+% You will have to specify the output driver to be used, either
+% |dvips| or |pdftex|.
+%
+% \begin{macro}{\PreviewBorder}
+% \begin{macro}{\PreviewBbAdjust}
+% We start this off with the user tunable parameters which get
+% defined even in the case of an inactive package, so that
+% redefinitions and assignments to them will always work:
+% \begin{macrocode}
+%<tightpage>\ifx\PreviewBorder\@undefined
+%<tightpage> \newdimen\PreviewBorder
+%<tightpage> \PreviewBorder=0.50001bp
+%<tightpage>\fi
+%<tightpage>\ifx\PreviewBbAdjust\@undefined
+%<tightpage> \def\PreviewBbAdjust{-\PreviewBorder -\PreviewBorder
+%<tightpage> \PreviewBorder \PreviewBorder}
+%<tightpage>\fi
+% \end{macrocode}
+% \end{macro}
+% \end{macro}
+% Here is stuff used for parsing this:
+% \begin{macrocode}
+%<tightpage>\ifPreview\else\expandafter\endinput\fi
+%<tightpage>\def\pr@nextbb{\edef\next{\next\space\number\dimen@}%
+%<tightpage> \expandafter\xdef\csname pr@bb@%
+%<tightpage> \romannumeral\count@\endcsname{\the\dimen@}%
+%<tightpage> \advance\count@\@ne\ifnum\count@<5
+%<tightpage> \afterassignment\pr@nextbb\dimen@=\fi}
+% \end{macrocode}
+% And here is the stuff that we fudge into our hook. Of course, we
+% have to do it in a box, and we start this box off with our special.
+% There is one small consideration here: it might come before any
+% |\AtBeginDvi| stuff containing header specials. It turns out Dvips
+% rearranges this amicably: header code specials get transferred to
+% the appropriate header section, anyhow, so this ensures that we come
+% right after the bop section. We insert the 7~numbers here: the
+% 4~bounding box adjustments, and the 3~\TeX\ box dimensions. In case
+% the box adjustments have changed since the last time, we write them
+% out to the console.
+% \begin{macrocode}
+%<tightpage>\ifnum\pr@graphicstype=\z@
+%<tightpage> \ifcase
+%<tightpage> \ifx\XeTeXversion\@undefined
+%<tightpage> \ifx\pdfoutput\@undefined \@ne\fi
+%<tightpage> \ifx\pdfoutput\relax \@ne\fi
+%<tightpage> \ifnum\pdfoutput>\z@ \tw@\fi \@ne
+%<tightpage> \else \thr@@\fi
+%<tightpage> \or \ExecuteOptions{dvips}\relax
+%<tightpage> \or \ExecuteOptions{pdftex}\relax
+%<tightpage> \or \ExecuteOptions{xetex}\relax\fi\fi
+%<tightpage>\global\let\pr@bbadjust\@empty
+%<tightpage>\pr@addto@front\pr@ship@end{\begingroup
+%<tightpage> \let\next\@gobble
+%<tightpage> \count@\@ne\afterassignment\pr@nextbb
+%<tightpage> \dimen@\PreviewBbAdjust
+%<tightpage> \ifx\pr@bbadjust\next
+%<tightpage> \else \global\let\pr@bbadjust\next
+%<tightpage> \typeout{Preview: Tightpage \pr@bbadjust}%
+%<tightpage> \fi\endgroup}
+%<tightpage>\ifcase\pr@graphicstype
+%<tightpage>\or
+%<tightpage> \g@addto@macro\pr@ship@end{\setbox\pr@box\hbox{%
+%<tightpage> \special{ps::\pr@bbadjust\space
+%<tightpage> \number\ifdim\ht\pr@box>\z@ \ht\pr@box
+%<tightpage> \else \z@
+%<tightpage> \fi \space
+%<tightpage> \number\ifdim\dp\pr@box>\z@ \dp\pr@box
+%<tightpage> \else \z@
+%<tightpage> \fi \space
+%<tightpage> \number\ifdim\wd\pr@box>\z@ \wd\pr@box
+%<tightpage> \else \z@
+%<tightpage> \fi}\box\pr@box}}
+%<tightpage>\or
+%<tightpage> \g@addto@macro\pr@ship@end{{\dimen@\ht\pr@box
+%<tightpage> \ifdim\dimen@<\z@ \dimen@\z@\fi
+%<tightpage> \advance\dimen@\pr@bb@iv
+%<tightpage> \dimen@ii=\dimen@
+%<tightpage> \global\pdfvorigin\dimen@
+%<tightpage> \dimen@\dp\pr@box
+%<tightpage> \ifdim\dimen@<\z@ \dimen@\z@\fi
+%<tightpage> \advance\dimen@-\pr@bb@ii
+%<tightpage> \advance\dimen@\dimen@ii
+%<tightpage> \global\pdfpageheight\dimen@
+%<tightpage> \dimen@\wd\pr@box
+%<tightpage> \ifdim\dimen@<\z@ \dimen@=\z@\fi
+%<tightpage> \advance\dimen@-\pr@bb@i
+%<tightpage> \advance\dimen@\pr@bb@iii
+%<tightpage> \global\pdfpagewidth\dimen@
+%<tightpage> \global\pdfhorigin-\pr@bb@i}}
+%<tightpage>\or
+%<tightpage> \g@addto@macro\pr@ship@end{\dimen@\ht\pr@box
+%<tightpage> \ifdim\dimen@<\z@ \dimen@\z@\fi
+%<tightpage> \advance\dimen@\pr@bb@iv
+%<tightpage> \dimen@ii=\dimen@
+%<tightpage> \voffset=-1in
+%<tightpage> \advance\voffset\dimen@
+%<tightpage> \advance\voffset-\ht\pr@box
+%<tightpage> \dimen@\dp\pr@box
+%<tightpage> \ifdim\dimen@<\z@ \dimen@\z@\fi
+%<tightpage> \advance\dimen@-\pr@bb@ii
+%<tightpage> \advance\dimen@\dimen@ii
+%<tightpage> \global\pdfpageheight\dimen@
+%<tightpage> \global\paperheight\dimen@
+%<tightpage> \dimen@\wd\pr@box
+%<tightpage> \ifdim\dimen@<\z@ \dimen@=\z@\fi
+%<tightpage> \advance\dimen@-\pr@bb@i
+%<tightpage> \advance\dimen@\pr@bb@iii
+%<tightpage> \global\pdfpagewidth\dimen@
+%<tightpage> \hoffset=-1in
+%<tightpage> \advance\hoffset-\pr@bb@i
+%<tightpage> \let\pr@offset@override\@empty}
+%<tightpage>\fi
+% \end{macrocode}
+% Ok, here comes the beef. First we fish the 7~numbers from the file
+% with |token| and convert them from \TeX~|sp| to PostScript points.
+% \begin{macrocode}
+%<tightpage>\ifnum\pr@graphicstype=\@ne
+%<tightpage>\preview@delay{\AtBeginDvi{%
+% \end{macrocode}
+% Backwards-compatibility. Once we are certain that dvipng-1.6 or
+% later is widely used, the three following specials can be exchanged
+% for the simple |\special{!/preview@tightpage true def}|
+% \begin{macrocode}
+%<tightpage> \special{!/preview@tightpage true def (%
+%<tightpage> compatibility PostScript comment for dvipng<=1.5 }
+%<tightpage> \special{!userdict begin/bop-hook{%
+%<tightpage> 7{currentfile token not{stop}if
+%<tightpage> 65781.76 div DVImag mul}repeat
+%<tightpage> 72 add 72 2 copy gt{exch}if 4 2 roll
+%<tightpage> neg 2 copy lt{exch}if dup 0 gt{pop 0 exch}%
+%<tightpage> {exch dup 0 lt{pop 0}if}ifelse 720 add exch 720 add
+%<tightpage> 3 1 roll
+%<tightpage> 4{5 -1 roll add 4 1 roll}repeat
+%<tightpage> <</PageSize[5 -1 roll 6 index sub 5 -1 roll 5 index sub]%
+%<tightpage> /PageOffset[7 -2 roll [1 1 dtransform exch]%
+%<tightpage> {0 ge{neg}if exch}forall]>>setpagedevice%
+%<tightpage> //bop-hook exec}bind def end}
+%<tightpage> \special{!userdict (some extra code to avoid
+%<tightpage> dvipng>=1.6 unknown special:
+%<tightpage> 7{currentfile token not{stop}if 65781.76 div })) pop}
+% \end{macrocode}
+% The ``userdict'' at the start of the last special is also there to
+% avoid an unknown special in dvipng<=1.6. This is the end of the
+% backwards-compatibility code.
+% \begin{macrocode}
+%<tightpage> \special{!userdict begin/bop-hook{%
+%<tightpage> preview-bop-level 0 le{%
+%<tightpage> 7{currentfile token not{stop}if
+%<tightpage> 65781.76 div DVImag mul}repeat
+% \end{macrocode}
+% Next we produce the horizontal part of the bounding box as
+% \[ (1\mathrm{in},1\mathrm{in}) +
+% \bigl(\min(|\wd\pr@box|,0),\max(|\wd\pr@box|,0)\bigr) \]
+% and roll it to the bottom of the stack:
+% \begin{macrocode}
+%<tightpage> 72 add 72 2 copy gt{exch}if 4 2 roll
+% \end{macrocode}
+% Next is the vertical part of the bounding box. Depth counts in
+% negatively, and we again take $\min$ and $\max$ of possible extents
+% in the vertical direction, limited by 0. 720 corresponds to
+% $10\,\mathrm{in}$ and is the famous $1\,\mathrm{in}$ distance away
+% from the edge of letterpaper.
+% \begin{macrocode}
+%<tightpage> neg 2 copy lt{exch}if dup 0 gt{pop 0 exch}%
+%<tightpage> {exch dup 0 lt{pop 0}if}ifelse 720 add exch 720 add
+%<tightpage> 3 1 roll
+% \end{macrocode}
+% Ok, we now have the bounding box on the stack in the proper order
+% llx, lly, urx, ury. We add the adjustments:
+% \begin{macrocode}
+%<tightpage> 4{5 -1 roll add 4 1 roll}repeat
+% \end{macrocode}
+% The page size is calculated as the appropriate differences, the page
+% offset consists of the coordinates of the lower left corner, with
+% those coordinates negated that would be reckoned positive in the
+% device coordinate system.
+% \begin{macrocode}
+%<tightpage> <</PageSize[5 -1 roll 6 index sub 5 -1 roll 5 index sub]%
+%<tightpage> /PageOffset[7 -2 roll [1 1 dtransform exch]%
+%<tightpage> {0 ge{neg}if exch}forall]>>setpagedevice}if%
+% \end{macrocode}
+% So we now bind the old definition of |bop-hook| into our new
+% definition and finish it.
+% \begin{macrocode}
+%<tightpage> //bop-hook exec}bind def end}}}
+%<tightpage>\fi
+% \end{macrocode}
+%
+% \subsection{The \texttt{showlabels} option}
+% During the editing process, some people like to see the label names
+% in their equations, figures and the like. Now if you are using
+% Emacs for editing, and in particular \previewlatex, I'd strongly
+% recommend that you check out the Ref\TeX\ package which pretty much
+% obliterates the need for this kind of functionality. If you still
+% want it, standard \LaTeX\ provides it with the |showkeys| package,
+% and there is also the less encompassing |showlabels| package.
+% Unfortunately, since those go to some pain not to change the page
+% layout and spacing, they also don't change |preview|'s idea of the
+% \TeX\ dimensions of the involved boxes.
+%
+% So those packages are mostly useless. So we present here an
+% alternative hack that will get the labels through.
+% \begin{macro}{\pr@labelbox}
+% This works by collecting them into a separate box which we then
+% tack to the right of the previews.
+% \begin{macrocode}
+%<showlabels>\ifPreview\else\expandafter\endinput\fi
+%<showlabels>\newbox\pr@labelbox
+% \end{macrocode}
+% \end{macro}
+% \begin{macro}{\pr@label}
+% We follow up with our own definition of the \cmd{\label} macro
+% which will be active only in previews. The original definition is
+% stored in |\pr@@label|. |\pr@lastlabel| contains the last typeset
+% label in order to avoid duplication in certain environments, and
+% we keep the stuff in |\pr@labelbox|.
+% \begin{macrocode}
+%<showlabels>\def\pr@label#1{\pr@@label{#1}%
+% \end{macrocode}
+% Ok, now we generate the box, by placing the label below any existing
+% stuff.
+% \begin{macrocode}
+%<showlabels> \ifpr@setbox\z@{#1}%
+%<showlabels> \global\setbox\pr@labelbox\vbox{\unvbox\pr@labelbox
+%<showlabels> \box\z@}\egroup\fi}
+% \end{macrocode}
+% \end{macro}
+% \begin{macro}{\ifpr@setbox}
+% |\ifpr@setbox| receives two arguments, |#1| is the box into which
+% to set a label, |#2| is the label text itself. If a label needs
+% to be set (if it is not a duplicate in the current box, and is
+% nonempty, and we are in the course of typesetting and so on), we
+% are left in a true conditional and an open group with the preset
+% box. If nothing should be set, no group is opened, and we get
+% into skipping to the closing of the conditional. Since
+% |\ifpr@setbox| is a macro, you should not place the call to it
+% into conditional text, since it will not pair up with |\fi| until
+% being expanded.
+%
+% We have some trickery involved here. |\romannumeral\z@| expands
+% to empty, and will also remove everything between the two of them
+% that also expands to empty, like a chain of |\fi|.
+% \begin{macrocode}
+%<showlabels>\def\ifpr@setbox#1#2{%
+%<showlabels> \romannumeral%
+%<showlabels> \ifx\protect\@typeset@protect\ifpr@outer\else
+% \end{macrocode}
+% Ignore empty labels\dots
+% \begin{macrocode}
+%<showlabels> \z@\bgroup
+%<showlabels> \protected@edef\next{#2}\@onelevel@sanitize\next
+%<showlabels> \ifx\next\@empty\egroup\romannumeral\else
+% \end{macrocode}
+% and labels equal to the last one.
+% \begin{macrocode}
+%<showlabels> \ifx\next\pr@lastlabel\egroup\romannumeral\else
+%<showlabels> \global\let\pr@lastlabel\next
+%<showlabels> \setbox#1\pr@boxlabel\pr@lastlabel
+%<showlabels> \expandafter\expandafter\romannumeral\fi\fi\fi\fi
+%<showlabels> \z@\iffalse\iftrue\fi}
+% \end{macrocode}
+% \end{macro}
+% \begin{macro}{\pr@boxlabel}
+% Now the actual typesetting of a label box is done. We use a small
+% typewriter font inside of a framed box (the default frame/box
+% separating distance is a bit large).
+% \begin{macrocode}
+%<showlabels>\def\pr@boxlabel#1{\hbox{\normalfont
+%<showlabels> \footnotesize\ttfamily\fboxsep0.4ex\relax\fbox{#1}}}
+% \end{macrocode}
+% \end{macro}
+% \begin{macro}{\pr@maketag}
+% And here is a version for |amsmath| equations. They look better
+% when the label is right beside the tag, so we place it there, but
+% augment |\box\pr@labelbox| with an appropriate placeholder.
+% \begin{macrocode}
+%<showlabels>\def\pr@maketag#1{\pr@@maketag{#1}%
+%<showlabels> \ifpr@setbox\z@{\df@label}%
+%<showlabels> \global\setbox\pr@labelbox\vbox{%
+%<showlabels> \hrule\@width\wd\z@\@height\z@
+%<showlabels> \unvbox\pr@labelbox}%
+% \end{macrocode}
+% Set the width of the box to empty so that the label placement gets
+% not disturbed, then append it.
+% \begin{macrocode}
+%<showlabels> \wd\z@\z@\box\z@ \egroup\fi}
+% \end{macrocode}
+% \end{macro}
+% \begin{macro}{\pr@lastlabel}
+% Ok, here is how we activate this: we clear out box and label info
+% \begin{macrocode}
+%<showlabels>\g@addto@macro\pr@ship@start{%
+%<showlabels> \global\setbox\pr@labelbox\box\voidb@x
+%<showlabels> \xdef\pr@lastlabel{}%
+% \end{macrocode}
+% The definitions above are global because we might be in any amount
+% of nesting. We then reassign the appropriate labelling macros:
+% \begin{macrocode}
+%<showlabels> \global\let\pr@@label\label \let\label\pr@label
+%<showlabels> \global\let\pr@@maketag\maketag@@@
+%<showlabels> \let\maketag@@@\pr@maketag
+%<showlabels>}
+% \end{macrocode}
+% \end{macro}
+% Now all we have to do is to add the stuff to the box in question.
+% The stuff at the front works around a bug in |ntheorem.sty|.
+% \begin{macrocode}
+%<showlabels>\pr@addto@front\pr@ship@end{%
+%<showlabels> \ifx \label\pr@label \global\let\label\pr@@label \fi
+%<showlabels> \ifx \maketag@@@\pr@maketag
+%<showlabels> \global\let\maketag@@@\pr@@maketag \fi
+%<showlabels> \ifvoid\pr@labelbox
+%<showlabels> \else \setbox\pr@box\hbox{%
+%<showlabels> \box\pr@box\,\box\pr@labelbox}%
+%<showlabels> \fi}
+% \end{macrocode}
+% \subsection{The \texttt{footnotes} option}
+% This is rather simplistic right now. It overrides the default
+% footnote action (which is to disable footnotes altogether for better
+% visibility).
+% \begin{macrocode}
+%<footnotes>\PreviewMacro[[!]\footnote %]
+% \end{macrocode}
+%
+% \section{Various driver files}
+% The installer, in case it is missing. If it is to be used via
+% |make|, we don't specify an installation path, since
+% \begin{quote}
+% |make install|
+% \end{quote}
+% is supposed to cater for the installation itself.
+% \begin{macrocode}
+%<installer> \input docstrip
+%<installer&make> \askforoverwritefalse
+%<installer> \generate{
+%<installer> \file{preview.drv}{\from{preview.dtx}{driver}}
+%<installer&!make> \usedir{tex/latex/preview}
+%<installer> \file{preview.sty}{\from{preview.dtx}{style}
+%<installer> \from{preview.dtx}{style,active}}
+%<installer> \file{prauctex.def}{\from{preview.dtx}{auctex}}
+%<installer> \file{prauctex.cfg}{\from{preview.dtx}{auccfg}}
+%<installer> \file{prshowbox.def}{\from{preview.dtx}{showbox}}
+%<installer> \file{prshowlabels.def}{\from{preview.dtx}{showlabels}}
+%<installer> \file{prtracingall.def}{\from{preview.dtx}{tracingall}}
+%<installer> \file{prtightpage.def}{\from{preview.dtx}{tightpage}}
+%<installer> \file{prlyx.def}{\from{preview.dtx}{lyx}}
+%<installer> \file{prcounters.def}{\from{preview.dtx}{counters}}
+%<installer> \file{prfootnotes.def}{\from{preview.dtx}{footnotes}}
+%<installer> }
+%<installer> \endbatchfile
+% \end{macrocode}
+% And here comes the documentation driver.
+% \begin{macrocode}
+%<driver> \documentclass{ltxdoc}
+%<driver> \usepackage{preview}
+%<driver> \let\ifPreview\relax
+%<driver> \newcommand\previewlatex{\texttt{preview-latex}}
+%<driver> \begin{document}
+%<driver> \DocInput{preview.dtx}
+%<driver> \end{document}
+% \end{macrocode}
+% \Finale{}
+% \iffalse
+% Local Variables:
+% mode: doctex
+% TeX-master: "preview.drv"
+% End:
+% \fi
--- /dev/null
+%%
+%% This is file `preview.ins',
+%% generated with the docstrip utility.
+%%
+%% The original source files were:
+%%
+%% preview.dtx (with options: `installer')
+%%
+%% IMPORTANT NOTICE:
+%%
+%% For the copyright see the source file.
+%%
+%% Any modified versions of this file must be renamed
+%% with new filenames distinct from preview.ins.
+%%
+%% For distribution of the original source see the terms
+%% for copying and modification in the file preview.dtx.
+%%
+%% This generated file may be distributed as long as the
+%% original source files, as listed above, are part of the
+%% same distribution. (The sources need not necessarily be
+%% in the same archive or directory.)
+%% The preview style for extracting previews from LaTeX documents.
+%% Developed as part of AUCTeX <URL:http://www.gnu.org/software/auctex>.
+ \input docstrip
+ \generate{
+ \file{preview.drv}{\from{preview.dtx}{driver}}
+ \usedir{tex/latex/preview}
+ \file{preview.sty}{\from{preview.dtx}{style}
+ \from{preview.dtx}{style,active}}
+ \file{prauctex.def}{\from{preview.dtx}{auctex}}
+ \file{prauctex.cfg}{\from{preview.dtx}{auccfg}}
+ \file{prshowbox.def}{\from{preview.dtx}{showbox}}
+ \file{prshowlabels.def}{\from{preview.dtx}{showlabels}}
+ \file{prtracingall.def}{\from{preview.dtx}{tracingall}}
+ \file{prtightpage.def}{\from{preview.dtx}{tightpage}}
+ \file{prlyx.def}{\from{preview.dtx}{lyx}}
+ \file{prcounters.def}{\from{preview.dtx}{counters}}
+ \file{prfootnotes.def}{\from{preview.dtx}{footnotes}}
+ }
+ \endbatchfile
+\endinput
+%%
+%% End of file `preview.ins'.
--- /dev/null
+%%
+%% This is file `preview.sty',
+%% generated with the docstrip utility.
+%%
+%% The original source files were:
+%%
+%% preview.dtx (with options: `style')
+%% preview.dtx (with options: `style,active')
+%%
+%% IMPORTANT NOTICE:
+%%
+%% For the copyright see the source file.
+%%
+%% Any modified versions of this file must be renamed
+%% with new filenames distinct from preview.sty.
+%%
+%% For distribution of the original source see the terms
+%% for copying and modification in the file preview.dtx preview.dtx.
+%%
+%% This generated file may be distributed as long as the
+%% original source files, as listed above, are part of the
+%% same distribution. (The sources need not necessarily be
+%% in the same archive or directory.)
+%% The preview style for extracting previews from LaTeX documents.
+%% Developed as part of AUCTeX <URL:http://www.gnu.org/software/auctex>.
+\NeedsTeXFormat{LaTeX2e} \def\reserved@a #1#2$#3:
+#4${\xdef#1{\reserved@c #2#4 $}} \def\reserved@c #1 #2${#1}
+\begingroup \catcode`\_=12
+\reserved@a\pr@version $Name: release_11_86 $ \ifx\pr@version\@empty
+\reserved@a\pr@version CVS-$Revision: 1.126 $ \endgroup \else
+ \def\next release_{} \lccode`\_=`.
+ \edef\next{\lowercase{\endgroup
+ \def\noexpand\pr@version{\expandafter\next\pr@version}}} \next \fi
+\reserved@a\next $Date: 2010/02/14 16:19:00 $
+\edef\next{\noexpand\ProvidesPackage{preview}%
+ [\next\space \pr@version\space (AUCTeX/preview-latex)]}
+\next
+\let\ifPreview\iffalse
+\let\preview@delay=\@gobble
+\let\pr@advise=\@gobbletwo
+\long\def\pr@advise@ship#1#2#3{}
+\def\pr@loadcfg#1{\InputIfFileExists{#1.cfg}{}{}}
+\DeclareOption{noconfig}{\let\pr@loadcfg=\@gobble}
+\long\def\pr@addto@front#1#2{%
+ \toks@{#2}\toks@\expandafter{\the\expandafter\toks@#1}%
+ \xdef#1{\the\toks@}}
+\DeclareOption{active}{%
+ \let\ifPreview\iftrue
+ \def\pr@advise#1{%
+ \expandafter\pr@adviseii\csname pr@\string#1\endcsname#1}%
+ \long\def\pr@advise@ship#1#2#3{\pr@advise#1{\pr@protect@ship{#2}{#3}}}%
+ \let\preview@delay\@firstofone}
+\long\def\pr@adviseii#1#2#3{\preview@delay{%
+ \ifx#1\relax \let#1#2\fi
+ \toks@{#3#1}%
+ \ifx\@undefined\protected \else \protected\fi
+ \long\edef#2{\the\toks@}}}
+\DeclareOption{delayed}{%
+ \ifPreview \def\preview@delay{\AtBeginDocument}\fi
+}
+\newif\ifpr@fixbb
+\pr@fixbbfalse
+\DeclareOption{psfixbb}{\ifPreview%
+ \pr@fixbbtrue
+ \newbox\pr@markerbox
+ \setbox\pr@markerbox\hbox{\special{psfile=/dev/null}}\fi
+}
+\let\pr@graphicstype=\z@
+\DeclareOption{dvips}{%
+ \let\pr@graphicstype\@ne
+ \preview@delay{\AtBeginDvi{%
+ \special{!/preview@version(\pr@version)def}
+ \special{!userdict begin/preview-bop-level 0 def%
+ /bop-hook{/preview-bop-level dup load dup 0 le{/isls false def%
+ /vsize 792 def/hsize 612 def}if 1 add store}bind def%
+ /eop-hook{/preview-bop-level dup load dup 0 gt{1 sub}if
+ store}bind def end}}}}
+\DeclareOption{pdftex}{%
+ \let\pr@graphicstype\tw@}
+\DeclareOption{xetex}{%
+ \let\pr@graphicstype\thr@@}
+\begingroup
+\catcode`\*=11
+\@firstofone{\endgroup
+\DeclareOption{displaymath}{%
+ \preview@delay{\toks@{%
+ \pr@startbox{\noindent$$%
+ \aftergroup\pr@endbox\@gobbletwo}{$$}\@firstofone}%
+ \everydisplay\expandafter{\the\expandafter\toks@
+ \expandafter{\the\everydisplay}}}%
+ \pr@advise@ship\equation{\begingroup\aftergroup\pr@endbox
+ \def\dt@ptrue{\m@ne=\m@ne}\noindent}%
+ {\endgroup}%
+ \pr@advise@ship\equation*{\begingroup\aftergroup\pr@endbox
+ \def\dt@ptrue{\m@ne=\m@ne}\noindent}%
+ {\endgroup}%
+ \PreviewOpen[][\def\dt@ptrue{\m@ne=\m@ne}\noindent#1]\[%
+ \PreviewClose\]%
+ \PreviewEnvironment[][\noindent#1]{eqnarray}%
+ \PreviewEnvironment[][\noindent#1]{eqnarray*}%
+ \PreviewEnvironment{displaymath}%
+}}
+\begingroup
+\def\next#1#2{%
+ \endgroup
+ \DeclareOption{textmath}{%
+ \PreviewEnvironment{math}%
+ \preview@delay{\ifx#1\@undefined \let#1=$%$
+ \fi\catcode`\$=\active
+ \ifx\xyreuncatcodes\@undefined\else
+ \edef\next{\catcode`@=\the\catcode`@\relax}%
+ \makeatother\expandafter\xyreuncatcodes\next\fi}%
+ \pr@advise@ship\(\pr@endaftergroup{}% \)
+ \pr@advise@ship#1{\@firstoftwo{\let#1=#2%
+ \futurelet\reserved@a\pr@textmathcheck}}{}}%
+ \def\pr@textmathcheck{\expandafter\pr@endaftergroup
+ \ifx\reserved@a#1{#2#2}\expandafter\@gobbletwo\fi#2}}
+\lccode`\~=`\$
+\lowercase{\expandafter\next\expandafter~}%
+ \csname pr@\string$%$
+ \endcsname
+\DeclareOption{graphics}{%
+ \PreviewMacro[*[[!]{\includegraphics}%]]
+}
+\def\pr@floatfix#1#2{\ifx#1#2%
+ \ifx#1\@undefined\else
+ \PackageWarningNoLine{preview}{%
+Your document class has a bad definition^^J
+of \string#1, most likely^^J
+\string\let\string#1=\string#2^^J
+which has now been changed to^^J
+\string\def\string#1{\string#2}^^J
+because otherwise subsequent changes to \string#2^^J
+(like done by several packages changing float behaviour)^^J
+can't take effect on \string#1.^^J
+Please complain to your document class author}%
+ \def#1{#2}\fi\fi}
+\begingroup
+\def\next#1#2{\endgroup
+ \DeclareOption{floats}{%
+ \pr@floatfix\endfigure\end@float
+ \pr@floatfix\endtable\end@float
+ \pr@floatfix#1\end@dblfloat
+ \pr@floatfix#2\end@dblfloat
+ \PreviewSnarfEnvironment[![]{@float}%]
+ \PreviewSnarfEnvironment[![]{@dblfloat}%]
+ }}
+\expandafter\next\csname endfigure*\expandafter\endcsname
+ \csname endtable*\endcsname
+\DeclareOption{sections}{%
+ \PreviewMacro[!!!!!!*[[!]{\@startsection}%]]
+ \PreviewMacro[*[[!]{\chapter}%]]
+}
+\DeclareOption*
+ {\InputIfFileExists{pr\CurrentOption.def}{}{\OptionNotUsed}}
+\def\PreviewMacro{\@ifstar\pr@starmacro\pr@macro}
+\long\def\pr@domacro#1#2{%
+ \long\def\next##1{#2}%
+ \pr@callafter\next#1]\pr@endparse}
+\newcommand\pr@macro[1][]{%
+ \toks@{\pr@domacro{#1}}%
+ \long\edef\next[##1]##2{%
+ \noexpand\pr@advise@ship{##2}{\the\toks@{##1\noexpand\pr@endbox}}{}}%
+ \@ifnextchar[\next\pr@macroii}
+\def\pr@macroii{\next[##1]}
+\long\def\pr@endmacro#1{#1\pr@endbox}
+\long\def\pr@protect@domacro#1#2{\pr@protect{%
+ \long\def\next##1{#2}%
+ \pr@callafter\next#1]\pr@endparse}}
+\newcommand\pr@starmacro[1][]{\toks@{\pr@protect@domacro{#1}}%
+ \long\edef\next[##1]##2{%
+ \noexpand\pr@advise##2{\the\toks@{##1}}}%
+ \@ifnextchar[\next{\next[]}}
+\def\PreviewOpen{\@ifstar\pr@starmacro\pr@open}
+\newcommand\pr@open[1][]{%
+ \toks@{\pr@domacro{#1}}%
+ \long\edef\next[##1]##2{%
+ \noexpand\pr@advise##2{\begingroup
+ \noexpand\pr@protect@ship
+ {\the\toks@{\begingroup\aftergroup\noexpand\pr@endbox##1}}%
+ {\endgroup}}}%
+ \@ifnextchar[\next\pr@macroii}
+\def\PreviewClose{\@ifstar\pr@starmacro\pr@close}
+\newcommand\pr@close[1][]{%
+ \toks@{\pr@domacro{#1}}%
+ \long\edef\next[##1]##2{%
+ \noexpand\pr@advise{##2}{\the\toks@{##1\endgroup}}}%
+ \@ifnextchar[\next\pr@macroii}
+\def\PreviewEnvironment{\@ifstar\pr@starenv\pr@env}
+\newcommand\pr@starenv[1][]{\toks@{\pr@starmacro[{#1}]}%
+ \long\edef\next##1##2{%
+ \the\toks@[{##2}]##1}%
+ \begingroup\pr@starenvii}
+\newcommand\pr@starenvii[2][]{\endgroup
+ \expandafter\next\csname#2\endcsname{#1}%
+ \expandafter\pr@starmacro\csname end#2\endcsname}
+\newcommand\pr@env[1][]{%
+ \toks@{\pr@domacro{#1}}%
+ \long\edef\next[##1]##2{%
+ \noexpand\expandafter\noexpand\pr@advise@ship
+ \noexpand\csname##2\noexpand\endcsname{\the\toks@
+ {\begingroup\aftergroup\noexpand\pr@endbox##1}}{\endgroup}}%
+ \@ifnextchar[\next\pr@macroii %]
+ }
+\newcommand{\PreviewSnarfEnvironment}[2][]{%
+ \expandafter\pr@advise
+ \csname #2\endcsname{\pr@snarfafter{#1}}%
+ \expandafter\pr@advise
+ \csname end#2\endcsname{\pr@endsnarf}}
+\let\pr@ship@start\@empty
+\let\pr@ship@end\@empty
+\newenvironment{preview}{\ignorespaces}{\ifhmode\unskip\fi}
+\newenvironment{nopreview}{\ignorespaces}{\ifhmode\unskip\fi}
+\ProcessOptions\relax
+\ifPreview\else\expandafter\endinput\fi
+%% The preview style for extracting previews from LaTeX documents.
+%% Developed as part of AUCTeX <URL:http://www.gnu.org/software/auctex>.
+\newif\ifpr@outer
+\pr@outertrue
+\newcount\pr@snippet
+\global\pr@snippet=1
+\def\pr@protect{\ifx\protect\@typeset@protect
+ \ifpr@outer \expandafter\expandafter\expandafter
+ \@secondoftwo\fi\fi\@gobble}
+\def\pr@protect@ship{\pr@protect{\@firstoftwo\pr@startbox}%
+ \@gobbletwo}
+\def\pr@insert{\begingroup\afterassignment\pr@insertii\count@}
+\def\pr@insertii{\endgroup\setbox\pr@box\vbox}
+\def\pr@mark{{\afterassignment}\toks@}
+\def\pr@marks{{\aftergroup\pr@mark\afterassignment}\count@}
+\newbox\pr@box
+\long\def\pr@startbox#1#2{%
+ \ifpr@outer
+ \toks@{#2}%
+ \edef\pr@cleanup{\the\toks@}%
+ \setbox\pr@box\vbox\bgroup
+ \break
+ \pr@outerfalse\@arrayparboxrestore
+ \let\insert\pr@insert
+ \let\mark\pr@mark
+ \let\marks\pr@marks
+ \expandafter\expandafter\expandafter
+ \pr@ship@start
+ \expandafter\@firstofone
+ \else
+ \expandafter \@gobble
+ \fi{#1}}
+\def\pr@endbox{%
+ \let\reserved@a\relax
+ \ifvmode \edef\reserved@a{\the\everypar}%
+ \ifx\reserved@a\@empty\else
+ \dimen@\prevdepth
+ \noindent\par
+ \setbox\z@\lastbox\unskip\unpenalty
+ \prevdepth\dimen@
+ \setbox\z@\hbox\bgroup\penalty-\maxdimen\unhbox\z@
+ \ifnum\lastpenalty=-\maxdimen\egroup
+ \else\egroup\box\z@ \fi\fi\fi
+ \ifhmode \par\unskip\setbox\z@\lastbox
+ \nointerlineskip\hbox{\unhbox\z@\/}%
+ \else \unskip\unpenalty\unskip \fi
+ \egroup
+ \setbox\pr@box\vbox{%
+ \baselineskip\z@skip \lineskip\z@skip \lineskiplimit\z@
+ \@begindvi
+ \nointerlineskip
+ \splittopskip\z@skip\setbox\z@\vsplit\pr@box to\z@
+ \unvbox\z@
+ \nointerlineskip
+ %\color@setgroup
+ \box\pr@box
+ %\color@endgroup
+ }%
+ \pr@ship@end
+ {\let\protect\noexpand
+ \ifx\pr@offset@override\@undefined
+ \voffset=-\ht\pr@box
+ \hoffset=\z@
+ \fi
+ \c@page=\pr@snippet
+ \pr@shipout
+ \ifpr@fixbb\hbox{%
+ \dimen@\wd\pr@box
+ \@tempdima\ht\pr@box
+ \@tempdimb\dp\pr@box
+ \box\pr@box
+ \llap{\raise\@tempdima\copy\pr@markerbox\kern\dimen@}%
+ \lower\@tempdimb\copy\pr@markerbox}%
+ \else \box\pr@box \fi}%
+ \global\advance\pr@snippet\@ne
+ \pr@cleanup
+}
+\let\pr@shipout=\shipout
+\def\shipout{\deadcycles\z@\bgroup\setbox\z@\box\voidb@x
+ \afterassignment\pr@shipoutegroup\setbox\z@}
+\def\pr@shipoutegroup{\ifvoid\z@ \expandafter\aftergroup\fi \egroup}
+\def\pr@parseit#1{\csname pr@parse#1\endcsname}
+\let\pr@endparse=\@percentchar
+\def\next#1{%
+\def\pr@callafter{%
+ \afterassignment\pr@parseit
+ \let#1= }}
+\expandafter\next\csname pr@parse\pr@endparse\endcsname
+\long\expandafter\def\csname pr@parse*\endcsname#1\pr@endparse#2{%
+ \begingroup\toks@{#1\pr@endparse{#2}}%
+ \edef\next##1{\endgroup##1\the\toks@}%
+ \@ifstar{\next{\pr@parse@*}}{\next\pr@parseit}}
+\long\expandafter\def\csname pr@parse[\endcsname#1\pr@endparse#2{%
+ \begingroup\toks@{#1\pr@endparse{#2}}%
+ \edef\next##1{\endgroup##1\the\toks@}%
+ \@ifnextchar[{\next\pr@bracket}{\next\pr@parseit}}
+\long\def\pr@bracket#1\pr@endparse#2[#3]{%
+ \pr@parseit#1\pr@endparse{#2[{#3}]}}
+\expandafter\let\csname pr@parse]\endcsname=\pr@parseit
+\long\def\pr@parse#1\pr@endparse#2#3{%
+ \pr@parseit#1\pr@endparse{#2{#3}}}
+\expandafter\let\csname pr@parse!\endcsname=\pr@parse
+\long\expandafter\def\csname pr@parse?\endcsname#1#2\pr@endparse#3{%
+ \begingroup\toks@{#2\pr@endparse{#3}}%
+ \@ifnextchar#1{\pr@parsecond\@firstoftwo}%
+ {\pr@parsecond\@secondoftwo}}
+\def\pr@parsecond#1{\expandafter\endgroup
+ \expandafter\expandafter\expandafter\pr@parseit
+ \expandafter#1\the\toks@}
+ \long\def\pr@parse@#1#2\pr@endparse#3{%
+ \pr@parseit #2\pr@endparse{#3#1}}
+\long\expandafter\def\csname pr@parse-\endcsname
+ #1\pr@endparse#2{\begingroup
+ \toks@{\endgroup\pr@parseit #1\pr@endparse{#2}}%
+ {\aftergroup\the\aftergroup\toks@ \afterassignment}%
+ \let\next= }
+\long\expandafter\def\csname pr@parse:\endcsname
+ #1#2#3\pr@endparse#4{\begingroup
+ \toks@{\endgroup \pr@parseit#3\pr@endparse{#4}}%
+ \long\def\next#1{#2}%
+ \the\expandafter\toks@\next}
+\long\expandafter\def\csname pr@parse#\endcsname
+ #1#2#3\pr@endparse#4{\begingroup
+ \toks@{#4}%
+ \long\edef\next##1{\toks@{\the\toks@##1}}%
+ \toks@{\endgroup \pr@parseit#3\pr@endparse}%
+ \long\def\reserved@a#1{{#2}}%
+ \the\expandafter\next\reserved@a}
+\def\pr@endaftergroup#1{#1\aftergroup\pr@endbox}
+\let\pr@endsnarf\relax
+\long\def\pr@snarfafter#1{\ifpr@outer
+ \pr@ship@start
+ \let\pr@ship@start\relax
+ \let\pr@endsnarf\endgroup
+ \else
+ \let\pr@endsnarf\relax
+ \fi
+ \pr@protect{\pr@callafter\pr@startsnarf#1]\pr@endparse}}
+\def\pr@startsnarf#1{#1\begingroup
+ \pr@startbox{\begingroup\aftergroup\pr@endbox}{\endgroup}%
+ \ignorespaces}
+\renewenvironment{preview}{\begingroup
+ \pr@startbox{\begingroup\aftergroup\pr@endbox}%
+ {\endgroup}%
+ \ignorespaces}%
+ {\ifhmode\unskip\fi\endgroup}
+\renewenvironment{nopreview}{\pr@outerfalse\ignorespaces}%
+ {\ifhmode\unskip\fi}
+\newtoks\pr@output
+\pr@output\output
+\output{%
+ \pr@outerfalse
+ \let\@begindvi\@empty
+ \the\pr@output}
+\let\output\pr@output
+\def\pr@typeinfos{\typeout{Preview: Fontsize \f@size pt}%
+ \ifnum\mag=\@m\else\typeout{Preview: Magnification \number\mag}\fi
+ \ifx\pdfoutput\@undefined
+ \ifx\XeTeXversion\@undefined \else
+ % FIXME: The message should not be emitted if XeTeX does not produce
+ % PDF. There does not seem to be a primitive for that, though.
+ \typeout{Preview: PDFoutput 1}%
+ \fi
+ \else
+ \ifx\pdfoutput\relax \else
+ \ifnum\pdfoutput>\z@
+ \typeout{Preview: PDFoutput 1}%
+ \fi
+ \fi
+ \fi
+}
+\AtBeginDocument{\pr@typeinfos}
+\pr@loadcfg{prdefault}
+\endinput
+%%
+%% End of file `preview.sty'.
--- /dev/null
+%%
+%% This is file `prfootnotes.def',
+%% generated with the docstrip utility.
+%%
+%% The original source files were:
+%%
+%% preview.dtx (with options: `footnotes')
+%%
+%% IMPORTANT NOTICE:
+%%
+%% For the copyright see the source file.
+%%
+%% Any modified versions of this file must be renamed
+%% with new filenames distinct from prfootnotes.def.
+%%
+%% For distribution of the original source see the terms
+%% for copying and modification in the file preview.dtx.
+%%
+%% This generated file may be distributed as long as the
+%% original source files, as listed above, are part of the
+%% same distribution. (The sources need not necessarily be
+%% in the same archive or directory.)
+%% The preview style for extracting previews from LaTeX documents.
+%% Developed as part of AUCTeX <URL:http://www.gnu.org/software/auctex>.
+\PreviewMacro[[!]\footnote %]
+\endinput
+%%
+%% End of file `prfootnotes.def'.
--- /dev/null
+%%
+%% This is file `prlyx.def',
+%% generated with the docstrip utility.
+%%
+%% The original source files were:
+%%
+%% preview.dtx (with options: `lyx')
+%%
+%% IMPORTANT NOTICE:
+%%
+%% For the copyright see the source file.
+%%
+%% Any modified versions of this file must be renamed
+%% with new filenames distinct from prlyx.def.
+%%
+%% For distribution of the original source see the terms
+%% for copying and modification in the file preview.dtx.
+%%
+%% This generated file may be distributed as long as the
+%% original source files, as listed above, are part of the
+%% same distribution. (The sources need not necessarily be
+%% in the same archive or directory.)
+%% The preview style for extracting previews from LaTeX documents.
+%% Developed as part of AUCTeX <URL:http://www.gnu.org/software/auctex>.
+\ifPreview\else\expandafter\endinput\fi
+\pr@loadcfg{prlyx}
+\g@addto@macro\pr@ship@end{\typeout{Preview:
+ Snippet \number\pr@snippet\space
+ \number\ht\pr@box\space \number\dp\pr@box \space\number\wd\pr@box}}
+\endinput
+%%
+%% End of file `prlyx.def'.
--- /dev/null
+%%
+%% This is file `prshowbox.def',
+%% generated with the docstrip utility.
+%%
+%% The original source files were:
+%%
+%% preview.dtx (with options: `showbox')
+%%
+%% IMPORTANT NOTICE:
+%%
+%% For the copyright see the source file.
+%%
+%% Any modified versions of this file must be renamed
+%% with new filenames distinct from prshowbox.def.
+%%
+%% For distribution of the original source see the terms
+%% for copying and modification in the file preview.dtx.
+%%
+%% This generated file may be distributed as long as the
+%% original source files, as listed above, are part of the
+%% same distribution. (The sources need not necessarily be
+%% in the same archive or directory.)
+%% The preview style for extracting previews from LaTeX documents.
+%% Developed as part of AUCTeX <URL:http://www.gnu.org/software/auctex>.
+\ifPreview\else\expandafter\endinput\fi
+\AtEndOfPackage{%
+ \showboxbreadth\maxdimen
+ \showboxdepth\maxdimen}
+\g@addto@macro\pr@ship@end{\showbox\pr@box}
+\endinput
+%%
+%% End of file `prshowbox.def'.
--- /dev/null
+%%
+%% This is file `prshowlabels.def',
+%% generated with the docstrip utility.
+%%
+%% The original source files were:
+%%
+%% preview.dtx (with options: `showlabels')
+%%
+%% IMPORTANT NOTICE:
+%%
+%% For the copyright see the source file.
+%%
+%% Any modified versions of this file must be renamed
+%% with new filenames distinct from prshowlabels.def.
+%%
+%% For distribution of the original source see the terms
+%% for copying and modification in the file preview.dtx.
+%%
+%% This generated file may be distributed as long as the
+%% original source files, as listed above, are part of the
+%% same distribution. (The sources need not necessarily be
+%% in the same archive or directory.)
+%% The preview style for extracting previews from LaTeX documents.
+%% Developed as part of AUCTeX <URL:http://www.gnu.org/software/auctex>.
+\ifPreview\else\expandafter\endinput\fi
+\newbox\pr@labelbox
+\def\pr@label#1{\pr@@label{#1}%
+ \ifpr@setbox\z@{#1}%
+ \global\setbox\pr@labelbox\vbox{\unvbox\pr@labelbox
+ \box\z@}\egroup\fi}
+\def\ifpr@setbox#1#2{%
+ \romannumeral%
+ \ifx\protect\@typeset@protect\ifpr@outer\else
+ \z@\bgroup
+ \protected@edef\next{#2}\@onelevel@sanitize\next
+ \ifx\next\@empty\egroup\romannumeral\else
+ \ifx\next\pr@lastlabel\egroup\romannumeral\else
+ \global\let\pr@lastlabel\next
+ \setbox#1\pr@boxlabel\pr@lastlabel
+ \expandafter\expandafter\romannumeral\fi\fi\fi\fi
+ \z@\iffalse\iftrue\fi}
+\def\pr@boxlabel#1{\hbox{\normalfont
+ \footnotesize\ttfamily\fboxsep0.4ex\relax\fbox{#1}}}
+\def\pr@maketag#1{\pr@@maketag{#1}%
+ \ifpr@setbox\z@{\df@label}%
+ \global\setbox\pr@labelbox\vbox{%
+ \hrule\@width\wd\z@\@height\z@
+ \unvbox\pr@labelbox}%
+ \wd\z@\z@\box\z@ \egroup\fi}
+\g@addto@macro\pr@ship@start{%
+ \global\setbox\pr@labelbox\box\voidb@x
+ \xdef\pr@lastlabel{}%
+ \global\let\pr@@label\label \let\label\pr@label
+ \global\let\pr@@maketag\maketag@@@
+ \let\maketag@@@\pr@maketag
+}
+\pr@addto@front\pr@ship@end{%
+ \ifx \label\pr@label \global\let\label\pr@@label \fi
+ \ifx \maketag@@@\pr@maketag
+ \global\let\maketag@@@\pr@@maketag \fi
+ \ifvoid\pr@labelbox
+ \else \setbox\pr@box\hbox{%
+ \box\pr@box\,\box\pr@labelbox}%
+ \fi}
+\endinput
+%%
+%% End of file `prshowlabels.def'.
--- /dev/null
+%%
+%% This is file `prtightpage.def',
+%% generated with the docstrip utility.
+%%
+%% The original source files were:
+%%
+%% preview.dtx (with options: `tightpage')
+%%
+%% IMPORTANT NOTICE:
+%%
+%% For the copyright see the source file.
+%%
+%% Any modified versions of this file must be renamed
+%% with new filenames distinct from prtightpage.def.
+%%
+%% For distribution of the original source see the terms
+%% for copying and modification in the file preview.dtx.
+%%
+%% This generated file may be distributed as long as the
+%% original source files, as listed above, are part of the
+%% same distribution. (The sources need not necessarily be
+%% in the same archive or directory.)
+%% The preview style for extracting previews from LaTeX documents.
+%% Developed as part of AUCTeX <URL:http://www.gnu.org/software/auctex>.
+\ifx\PreviewBorder\@undefined
+ \newdimen\PreviewBorder
+ \PreviewBorder=0.50001bp
+\fi
+\ifx\PreviewBbAdjust\@undefined
+ \def\PreviewBbAdjust{-\PreviewBorder -\PreviewBorder
+ \PreviewBorder \PreviewBorder}
+\fi
+\ifPreview\else\expandafter\endinput\fi
+\def\pr@nextbb{\edef\next{\next\space\number\dimen@}%
+ \expandafter\xdef\csname pr@bb@%
+ \romannumeral\count@\endcsname{\the\dimen@}%
+ \advance\count@\@ne\ifnum\count@<5
+ \afterassignment\pr@nextbb\dimen@=\fi}
+\ifnum\pr@graphicstype=\z@
+ \ifcase
+ \ifx\XeTeXversion\@undefined
+ \ifx\pdfoutput\@undefined \@ne\fi
+ \ifx\pdfoutput\relax \@ne\fi
+ \ifnum\pdfoutput>\z@ \tw@\fi \@ne
+ \else \thr@@\fi
+ \or \ExecuteOptions{dvips}\relax
+ \or \ExecuteOptions{pdftex}\relax
+ \or \ExecuteOptions{xetex}\relax\fi\fi
+\global\let\pr@bbadjust\@empty
+\pr@addto@front\pr@ship@end{\begingroup
+ \let\next\@gobble
+ \count@\@ne\afterassignment\pr@nextbb
+ \dimen@\PreviewBbAdjust
+ \ifx\pr@bbadjust\next
+ \else \global\let\pr@bbadjust\next
+ \typeout{Preview: Tightpage \pr@bbadjust}%
+ \fi\endgroup}
+\ifcase\pr@graphicstype
+\or
+ \g@addto@macro\pr@ship@end{\setbox\pr@box\hbox{%
+ \special{ps::\pr@bbadjust\space
+ \number\ifdim\ht\pr@box>\z@ \ht\pr@box
+ \else \z@
+ \fi \space
+ \number\ifdim\dp\pr@box>\z@ \dp\pr@box
+ \else \z@
+ \fi \space
+ \number\ifdim\wd\pr@box>\z@ \wd\pr@box
+ \else \z@
+ \fi}\box\pr@box}}
+\or
+ \g@addto@macro\pr@ship@end{{\dimen@\ht\pr@box
+ \ifdim\dimen@<\z@ \dimen@\z@\fi
+ \advance\dimen@\pr@bb@iv
+ \dimen@ii=\dimen@
+ \global\pdfvorigin\dimen@
+ \dimen@\dp\pr@box
+ \ifdim\dimen@<\z@ \dimen@\z@\fi
+ \advance\dimen@-\pr@bb@ii
+ \advance\dimen@\dimen@ii
+ \global\pdfpageheight\dimen@
+ \dimen@\wd\pr@box
+ \ifdim\dimen@<\z@ \dimen@=\z@\fi
+ \advance\dimen@-\pr@bb@i
+ \advance\dimen@\pr@bb@iii
+ \global\pdfpagewidth\dimen@
+ \global\pdfhorigin-\pr@bb@i}}
+\or
+ \g@addto@macro\pr@ship@end{\dimen@\ht\pr@box
+ \ifdim\dimen@<\z@ \dimen@\z@\fi
+ \advance\dimen@\pr@bb@iv
+ \dimen@ii=\dimen@
+ \voffset=-1in
+ \advance\voffset\dimen@
+ \advance\voffset-\ht\pr@box
+ \dimen@\dp\pr@box
+ \ifdim\dimen@<\z@ \dimen@\z@\fi
+ \advance\dimen@-\pr@bb@ii
+ \advance\dimen@\dimen@ii
+ \global\pdfpageheight\dimen@
+ \global\paperheight\dimen@
+ \dimen@\wd\pr@box
+ \ifdim\dimen@<\z@ \dimen@=\z@\fi
+ \advance\dimen@-\pr@bb@i
+ \advance\dimen@\pr@bb@iii
+ \global\pdfpagewidth\dimen@
+ \hoffset=-1in
+ \advance\hoffset-\pr@bb@i
+ \let\pr@offset@override\@empty}
+\fi
+\ifnum\pr@graphicstype=\@ne
+\preview@delay{\AtBeginDvi{%
+ \special{!/preview@tightpage true def (%
+ compatibility PostScript comment for dvipng<=1.5 }
+ \special{!userdict begin/bop-hook{%
+ 7{currentfile token not{stop}if
+ 65781.76 div DVImag mul}repeat
+ 72 add 72 2 copy gt{exch}if 4 2 roll
+ neg 2 copy lt{exch}if dup 0 gt{pop 0 exch}%
+ {exch dup 0 lt{pop 0}if}ifelse 720 add exch 720 add
+ 3 1 roll
+ 4{5 -1 roll add 4 1 roll}repeat
+ <</PageSize[5 -1 roll 6 index sub 5 -1 roll 5 index sub]%
+ /PageOffset[7 -2 roll [1 1 dtransform exch]%
+ {0 ge{neg}if exch}forall]>>setpagedevice%
+ //bop-hook exec}bind def end}
+ \special{!userdict (some extra code to avoid
+ dvipng>=1.6 unknown special:
+ 7{currentfile token not{stop}if 65781.76 div })) pop}
+ \special{!userdict begin/bop-hook{%
+ preview-bop-level 0 le{%
+ 7{currentfile token not{stop}if
+ 65781.76 div DVImag mul}repeat
+ 72 add 72 2 copy gt{exch}if 4 2 roll
+ neg 2 copy lt{exch}if dup 0 gt{pop 0 exch}%
+ {exch dup 0 lt{pop 0}if}ifelse 720 add exch 720 add
+ 3 1 roll
+ 4{5 -1 roll add 4 1 roll}repeat
+ <</PageSize[5 -1 roll 6 index sub 5 -1 roll 5 index sub]%
+ /PageOffset[7 -2 roll [1 1 dtransform exch]%
+ {0 ge{neg}if exch}forall]>>setpagedevice}if%
+ //bop-hook exec}bind def end}}}
+\fi
+\endinput
+%%
+%% End of file `prtightpage.def'.
--- /dev/null
+%%
+%% This is file `prtracingall.def',
+%% generated with the docstrip utility.
+%%
+%% The original source files were:
+%%
+%% preview.dtx (with options: `tracingall')
+%%
+%% IMPORTANT NOTICE:
+%%
+%% For the copyright see the source file.
+%%
+%% Any modified versions of this file must be renamed
+%% with new filenames distinct from prtracingall.def.
+%%
+%% For distribution of the original source see the terms
+%% for copying and modification in the file preview.dtx.
+%%
+%% This generated file may be distributed as long as the
+%% original source files, as listed above, are part of the
+%% same distribution. (The sources need not necessarily be
+%% in the same archive or directory.)
+%% The preview style for extracting previews from LaTeX documents.
+%% Developed as part of AUCTeX <URL:http://www.gnu.org/software/auctex>.
+\ifPreview\else\expandafter\endinput\fi
+\pr@addto@front\pr@ship@start{\let\tracingonline\count@
+ \let\errorstopmode\@empty\tracingall}
+\endinput
+%%
+%% End of file `prtracingall.def'.
Require Import ExtractionMain.
+Require Import HaskProgrammingLanguage.
+Require Import PCF.
+Require Import HaskFlattener.
Require Import ProgrammingLanguageArrow.
Require Import ProgrammingLanguageReification.
Require Import ProgrammingLanguageFlattening.
+{-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-unused-binds -fno-warn-unused-imports #-}
module CoqPass ( coqPassCoreToString, coqPassCoreToCore )
where
import qualified Unique
+import qualified Kind
import qualified UniqSupply
import qualified MkCore
import qualified TysWiredIn
import qualified Type
import qualified TypeRep
import qualified DataCon
+import qualified DsMonad
+import qualified IOEnv
+import qualified TcRnTypes
import qualified TyCon
import qualified Coercion
import qualified Var
import qualified Id
+import qualified Pair
import qualified FastString
import qualified BasicTypes
import qualified DataCon
import qualified Data.Ord
import qualified Data.Typeable
import Data.Bits ((.&.), shiftL, (.|.))
-import Prelude ( (++), (+), (==), Show, show, Char, (.), ($) )
+import Prelude ( (++), (+), (==), Show, show, (.), ($) )
import qualified Prelude
-import qualified Debug.Trace
+import qualified HscTypes
import qualified GHC.Base
-import qualified System.IO
+import qualified CoreMonad
import qualified System.IO.Unsafe
getTyConTyVars :: TyCon.TyCon -> [Var.TyVar]
sortAlts :: [(CoreSyn.AltCon,[Var.Var],CoreSyn.Expr Var.Var)] -> [(CoreSyn.AltCon,[Var.Var],CoreSyn.Expr Var.Var)]
sortAlts x = Data.List.sortBy (\a b -> if a `CoreSyn.ltAlt` b then Data.Ord.LT else Data.Ord.GT) x
-coreVarToWeakVar :: Var.Var -> WeakVar
-coreVarToWeakVar v | Id.isId v = WExprVar (WeakExprVar v (errOrFail (coreTypeToWeakType (Var.varType v))))
-coreVarToWeakVar v | Var.isTyVar v = WTypeVar (WeakTypeVar v (coreKindToKind (Var.varType v)))
-coreVarToWeakVar v | Var.isCoVar v = WCoerVar (WeakCoerVar v (Prelude.error "FIXME")
- (Prelude.error "FIXME") (Prelude.error "FIXME"))
-coreVarToWeakVar _ =
- Prelude.error "Var.Var that is neither an expression variable, type variable, nor coercion variable!"
+coreVarToWeakVar :: Var.Var -> CoreVarToWeakVarResult
+coreVarToWeakVar v | Id.isId v = CVTWVR_EVar (Var.varType v)
+coreVarToWeakVar v | Var.isTyVar v = CVTWVR_TyVar (coreKindToKind (Var.varType v))
+coreVarToWeakVar v | Coercion.isCoVar v = CVTWVR_CoVar (Prelude.fst (Coercion.coVarKind v)) (Prelude.snd (Coercion.coVarKind v))
+coreVarToWeakVar _ = Prelude.error "Var.Var that is neither an expression, type variable, nor coercion variable!"
-errOrFail (OK x) = x
-errOrFail (Error s) = Prelude.error s
+rawTyFunKind :: TyCon.TyCon -> ( [Kind] , Kind )
+rawTyFunKind tc = ((Prelude.map coreKindToKind (Prelude.take (TyCon.tyConArity tc) argk))
+ ,
+ coreKindToKind (Coercion.mkArrowKinds (Prelude.drop (TyCon.tyConArity tc) argk) retk))
+ where (argk,retk) = Coercion.splitKindFunTys (TyCon.tyConKind tc)
tyConOrTyFun :: TyCon.TyCon -> Prelude.Either TyCon.TyCon TyCon.TyCon
tyConOrTyFun n =
then Prelude.Right n
else if TyCon.isFamInstTyCon n
then Prelude.Right n
- else Prelude.Left n
+ else if TyCon.isSynTyCon n
+ then Prelude.Right n
+ else Prelude.Left n
nat2int :: Nat -> Prelude.Int
nat2int O = 0
sanitizeForLatex (c:x) = c:(sanitizeForLatex x)
kindToCoreKind :: Kind -> TypeRep.Kind
-kindToCoreKind KindStar = TypeRep.liftedTypeKind
-kindToCoreKind (KindArrow k1 k2) = Coercion.mkArrowKind (kindToCoreKind k1) (kindToCoreKind k2)
-kindToCoreKind _ = Prelude.error "kindToCoreKind does not know how to handle that"
-
+kindToCoreKind KindStar = Kind.liftedTypeKind
+kindToCoreKind (KindArrow k1 k2) = Kind.mkArrowKind (kindToCoreKind k1) (kindToCoreKind k2)
+kindToCoreKind k = Prelude.error ((Prelude.++)
+ "kindToCoreKind does not know how to handle kind "
+ (kindToString k))
coreKindToKind :: TypeRep.Kind -> Kind
coreKindToKind k =
- case Coercion.splitKindFunTy_maybe k of
+ case Kind.splitKindFunTy_maybe k of
Prelude.Just (k1,k2) -> KindArrow (coreKindToKind k1) (coreKindToKind k2)
Prelude.Nothing ->
- if (Coercion.isLiftedTypeKind k) then KindStar
- else if (Coercion.isUnliftedTypeKind k) then KindStar
- else if (Coercion.isArgTypeKind k) then KindStar
- else if (Coercion.isUbxTupleKind k) then KindStar
- else if (Coercion.isOpenTypeKind k) then KindStar
+ if (Kind.isLiftedTypeKind k) then KindStar
+ else if (Kind.isUnliftedTypeKind k) then KindStar
+ else if (Kind.isArgTypeKind k) then KindStar
+ else if (Kind.isUbxTupleKind k) then KindStar
+ else if (Kind.isOpenTypeKind k) then KindStar
--
-- The "subkinding" in GHC is not dealt with in System FC, and dealing
-- with it is not actually as simple as you'd think.
-- else if (Coercion.isArgTypeKind k) then KindArgType
-- else if (Coercion.isUbxTupleKind k) then KindUnboxedTuple
--
- else if (Coercion.isTySuperKind k) then Prelude.error "coreKindToKind got the kind-of-the-kind-of-types"
- else if (Coercion.isCoSuperKind k) then Prelude.error "coreKindToKind got the kind-of-the-kind-of-coercions"
+ else if (Kind.isTySuperKind k) then Prelude.error "coreKindToKind got the kind-of-the-kind-of-types"
else Prelude.error ((Prelude.++) "coreKindToKind got an unknown kind: "
(Outputable.showSDoc (Outputable.ppr k)))
outputableToString :: Outputable.Outputable a => a -> Prelude.String
-outputableToString = (\x -> Outputable.showSDoc (Outputable.ppr x))
+outputableToString = (\x -> Outputable.showSDocDebug (Outputable.ppr x))
coreViewDeep :: Type.Type -> Type.Type
coreViewDeep t =
Prelude.Nothing -> TypeRep.PredTy p
Prelude.Just t' -> t'
-coreCoercionToWeakCoercion :: Type.Type -> WeakCoercion
-coreCoercionToWeakCoercion c =
- WCoUnsafe (errOrFail (coreTypeToWeakType t1)) (errOrFail (coreTypeToWeakType t2))
- where
- (t1,t2) = Coercion.coercionKind c
-{-
--- REMEMBER: cotycon applications may be oversaturated
- case c of
- TypeRep.TyVarTy v -> WCoVar (WeakCoerVar v (Prelude.error "FIXME") (Prelude.error "FIXME") (Prelude.error "FIXME"))
- TypeRep.AppTy t1 t2 -> WCoApp (coreCoercionToWeakCoercion t1) (coreCoercionToWeakCoercion t2)
- TypeRep.TyConApp tc t ->
- case TyCon.isCoercionTyCon_maybe tc of
- Prelude.Nothing -> Prelude.error ((Prelude.++) "coreCoercionToWeakCoercion got isCoercionTyCon_maybe " (outputableToString c))
- Prelude.Just (_, ctcd) ->
- case (ctcd,t) of
- (TyCon.CoTrans , [x,y] ) -> WCoComp (coreCoercionToWeakCoercion x) (coreCoercionToWeakCoercion y)
- (TyCon.CoSym , [x] ) -> WCoSym (coreCoercionToWeakCoercion x)
- (TyCon.CoLeft , [x] ) -> WCoLeft (coreCoercionToWeakCoercion x)
- (TyCon.CoRight , [x] ) -> WCoLeft (coreCoercionToWeakCoercion x)
--- (TyCon.CoUnsafe, [t1, t2 ] ) -> WCoUnsafe (coreTypeToWeakType t1) (coreTypeToWeakType t2)
- (TyCon.CoTrans , [] ) -> Prelude.error "CoTrans is not in post-publication-appendix SystemFC1"
- (TyCon.CoCsel1 , [] ) -> Prelude.error "CoCsel1 is not in post-publication-appendix SystemFC1"
- (TyCon.CoCsel2 , [] ) -> Prelude.error "CoCsel2 is not in post-publication-appendix SystemFC1"
- (TyCon.CoCselR , [] ) -> Prelude.error "CoCselR is not in post-publication-appendix SystemFC1"
- (TyCon.CoInst , [] ) -> Prelude.error "CoInst is not in post-publication-appendix SystemFC1"
- (TyCon.CoAxiom _ _ _ , _ ) -> Prelude.error "CoAxiom is not yet implemented (FIXME)"
- ( _, [ t1 , t2 ]) -> WCoUnsafe (errOrFail (coreTypeToWeakType t1)) (errOrFail (coreTypeToWeakType t2))
- _ -> Prelude.error ((Prelude.++) "coreCoercionToWeakCoercion got " (outputableToString c))
- _ -> Prelude.error ((Prelude.++) "coreCoercionToWeakCoercion got " (outputableToString c))
--}
--- TypeRep.ForAllTy v t -> WCoAll (Prelude.error "FIXME") (coreTypeToWeakType t)
--- FIXME x y -> WCoAppT (coreCoercionToWeakCoercion x) (coreCoercionToWeakType y)
--- CoreSyn.Type t -> WCoType (coreTypeToWeakType t)
-
-{-
-weakCoercionToCoreCoercion :: CoreCoercion -> Type.Type
-| WCoVar (weakCoerVar _ _ t1 t2) => (t1,t2)
-| WCoType t => Prelude_error "FIXME WCoType"
-| WCoApp c1 c2 => Prelude_error "FIXME WCoApp"
-| WCoAppT c t => Prelude_error "FIXME WCoAppT"
-| WCoAll k f => Prelude_error "FIXME WCoAll"
-| WCoSym c => let (t2,t1) := weakCoercionTypes c in (t1,t2)
-| WCoComp c1 c2 => Prelude_error "FIXME WCoComp"
-| WCoLeft c => Prelude_error "FIXME WCoLeft"
-| WCoRight c => Prelude_error "FIXME WCoRight"
-| WCoUnsafe t1 t2 => (t1,t2)
--}
-
+{-# NOINLINE trace #-}
+trace :: Prelude.String -> a -> a
+trace msg x = x
--trace = Debug.Trace.trace
--trace msg x = x
-trace msg x = System.IO.Unsafe.unsafePerformIO $ Prelude.return x
-{-
-trace s x = x
-trace msg x = System.IO.Unsafe.unsafePerformIO $
- (Prelude.>>=) (System.IO.hPutStrLn System.IO.stdout msg) (\_ -> Prelude.return x)
-trace msg x = System.IO.Unsafe.unsafePerformIO $
- (Prelude.>>=) (System.IO.hPutStr System.IO.stdout " ") (\_ -> Prelude.return x)
--}
-
-{- -- used for extracting strings WITHOUT the patch for Coq
-bin2ascii =
- (\ b0 b1 b2 b3 b4 b5 b6 b7 ->
- let f b i = if b then 1 `shiftL` i else 0
- in Data.Char.chr (f b0 0 .|. f b1 1 .|. f b2 2 .|. f b3 3 .|. f b4 4 .|. f b5 5 .|. f b6 6 .|. f b7 7))
--}
+--trace msg x = System.IO.Unsafe.unsafePerformIO $ Prelude.return x
+--trace s x = x
+--trace msg x = System.IO.Unsafe.unsafePerformIO $
+-- (Prelude.>>=) (System.IO.hPutStrLn System.IO.stdout msg) (\_ -> Prelude.return x)
+--trace msg x = System.IO.Unsafe.unsafePerformIO $
+-- (Prelude.>>=) (System.IO.hPutStr System.IO.stdout " ") (\_ -> Prelude.return x)
-- I'm leaving this here (commented out) in case I ever need it again)
--checkTypeEquality :: Type.Type -> Type.Type -> Prelude.Bool
Require Import General.
Require Import NaturalDeduction.
+Require Import NaturalDeductionContext.
Require Import HaskKinds.
-Require Import HaskLiteralsAndTyCons.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
Require Import HaskCoreVars.
Require Import HaskCoreTypes.
Require Import HaskCore.
Require Import HaskWeakToCore.
Require Import HaskProofToStrong.
-Require Import HaskProofFlattener.
-Require Import HaskProofStratified.
+Require Import HaskFlattener.
Open Scope string_scope.
Extraction Language Haskell.
Variable mkTyVar : Name -> Kind -> CoreVar.
Extract Inlined Constant mkTyVar => "(\n k -> Var.mkTyVar n (kindToCoreKind k))".
Variable mkCoVar : Name -> CoreType -> CoreType -> CoreVar.
- Extract Inlined Constant mkCoVar => "(\n t1 t2 -> Var.mkCoVar n (Coercion.mkCoKind t1 t2))".
+ Extract Inlined Constant mkCoVar => "(\n t1 t2 -> Var.mkCoVar n (Coercion.mkCoType t1 t2))".
Variable mkExVar : Name -> CoreType -> CoreVar.
Extract Inlined Constant mkExVar => "Id.mkLocalId".
+Variable CoreM : Type -> Type.
+ Extract Constant CoreM "a" => "CoreMonad.CoreM".
+ Extraction Inline CoreM.
+Variable CoreMreturn : forall a, a -> CoreM a.
+ Extraction Implicit CoreMreturn [a].
+ Implicit Arguments CoreMreturn [[a]].
+ Extract Inlined Constant CoreMreturn => "Prelude.return".
+Variable CoreMbind : forall a b, CoreM a -> (a -> CoreM b) -> CoreM b.
+ Extraction Implicit CoreMbind [a b].
+ Implicit Arguments CoreMbind [[a] [b]].
+ Extract Inlined Constant CoreMbind => "(Prelude.>>=)".
+
Section core2proof.
Context (ce:@CoreExpr CoreVar).
(* We need to be able to resolve unbound exprvars, but we can be sure their types will have no
* free tyvars in them *)
Definition ξ (cv:CoreVar) : LeveledHaskType Γ ★ :=
- match coreVarToWeakVar cv with
- | WExprVar wev => match weakTypeToTypeOfKind φ wev ★ with
+ match coreVarToWeakVar' cv with
+ | OK (WExprVar wev) => match weakTypeToTypeOfKind φ wev ★ with
| Error s => Prelude_error ("Error converting weakType of top-level variable "+++
toString cv+++": " +++ s)
| OK t => t @@ nil
end
- | WTypeVar _ => Prelude_error "top-level xi got a type variable"
- | WCoerVar _ => Prelude_error "top-level xi got a coercion variable"
+ | OK (WTypeVar _) => Prelude_error "top-level xi got a type variable"
+ | OK (WCoerVar _) => Prelude_error "top-level xi got a coercion variable"
+ | Error s => Prelude_error s
end.
-
Definition header : string :=
"\documentclass{article}"+++eol+++
"\usepackage{amsmath}"+++eol+++
"\usepackage{amssymb}"+++eol+++
"\usepackage{proof}"+++eol+++
-(* "\usepackage{mathpartir} % http://cristal.inria.fr/~remy/latex/"+++eol+++*)
"\usepackage{trfrac} % http://www.utdallas.edu/~hamlen/trfrac.sty"+++eol+++
"\def\code#1#2{\Box_{#1} #2}"+++eol+++
"\usepackage[paperwidth=\maxdimen,paperheight=\maxdimen]{geometry}"+++eol+++
OK (eol+++eol+++eol+++
"\begin{preview}"+++eol+++
"$\displaystyle "+++
- toString (nd_ml_toLatexMath (@expr2proof _ _ _ _ _ _ e))+++
+ toString (nd_ml_toLatexMath (@expr2proof _ _ _ _ _ _ _ e))+++
" $"+++eol+++
"\end{preview}"+++eol+++eol+++eol)
)))))))).
Definition mkWeakTypeVar (u:Unique)(k:Kind) : WeakTypeVar :=
weakTypeVar (mkTyVar (mkSystemName u "tv" O) k) k.
Definition mkWeakCoerVar (u:Unique)(k:Kind)(t1 t2:WeakType) : WeakCoerVar :=
- weakCoerVar (mkCoVar (mkSystemName u "cv" O) (weakTypeToCoreType t1) (weakTypeToCoreType t2)) k t1 t2.
+ weakCoerVar (mkCoVar (mkSystemName u "cv" O) (weakTypeToCoreType t1) (weakTypeToCoreType t2)) t1 t2.
Definition mkWeakExprVar (u:Unique)(t:WeakType) : WeakExprVar :=
weakExprVar (mkExVar (mkSystemName u "ev" O) (weakTypeToCoreType t)) t.
- Context (hetmet_brak : WeakExprVar).
- Context (hetmet_esc : WeakExprVar).
- Context (uniqueSupply : UniqSupply).
+ Context (hetmet_brak : WeakExprVar).
+ Context (hetmet_esc : WeakExprVar).
+ Context (hetmet_kappa : WeakExprVar).
+ Context (hetmet_kappa_app : WeakExprVar).
+ Context (uniqueSupply : UniqSupply).
Definition useUniqueSupply {T}(ut:UniqM T) : ???T :=
match ut with
apply t.
Defined.
- Definition coreToCoreExpr' (ce:@CoreExpr CoreVar) : ???(@CoreExpr CoreVar) :=
- addErrorMessage ("input CoreSyn: " +++ toString ce)
- (addErrorMessage ("input CoreType: " +++ toString (coreTypeOfCoreExpr ce)) (
- coreExprToWeakExpr ce >>= fun we =>
+ End CoreToCore.
+
+ Definition coreVarToWeakExprVarOrError cv :=
+ match addErrorMessage ("in coreVarToWeakExprVarOrError" +++ eol) (coreVarToWeakVar' cv) with
+ | OK (WExprVar wv) => wv
+ | Error s => Prelude_error s
+ | _ => Prelude_error "IMPOSSIBLE"
+ end.
+
+ Definition curry {Γ}{Δ}{a}{s}{Σ}{lev} :
+ ND Rule
+ [ Γ > Δ > Σ |- [a ---> s ]@lev ]
+ [ Γ > Δ > [a @@ lev],,Σ |- [ s ]@lev ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AExch ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RApp ].
+ eapply nd_comp; [ apply nd_rlecnac | idtac ].
+ apply nd_prod.
+ apply nd_id.
+ apply nd_rule.
+ apply RVar.
+ Defined.
+
+ Definition fToC1 {Γ}{Δ}{a}{s}{lev} :
+ ND Rule [] [ Γ > Δ > [ ] |- [a ---> s ]@lev ] ->
+ ND Rule [] [ Γ > Δ > [a @@ lev] |- [ s ]@lev ].
+ intro pf.
+ eapply nd_comp.
+ apply pf.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; apply ACanR ].
+ apply curry.
+ Defined.
+
+ Definition fToC1' {Γ}{Δ}{a}{s}{lev} :
+ ND Rule [] [ Γ > Δ > [ ] |- [a ---> s ]@lev ] ->
+ ND Rule [] [ Γ > Δ > [a @@ lev] |- [ s ]@lev ].
+ intro pf.
+ eapply nd_comp.
+ apply pf.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; apply ACanR ].
+ apply curry.
+ Defined.
+
+ Definition fToC2 {Γ}{Δ}{a1}{a2}{s}{lev} :
+ ND Rule [] [ Γ > Δ > [] |- [a1 ---> (a2 ---> s) ]@lev ] ->
+ ND Rule [] [ Γ > Δ > [a1 @@ lev],,[a2 @@ lev] |- [ s ]@lev ].
+ intro pf.
+ eapply nd_comp.
+ eapply pf.
+ clear pf.
+ eapply nd_comp.
+ eapply curry.
+ eapply nd_comp.
+ eapply nd_rule.
+ eapply RArrange.
+ eapply ACanR.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AExch ].
+ apply curry.
+ Defined.
+
+ Definition fToCx {Γ}{Δ}{a1}{a2}{a3}{l} Σ :
+ ND Rule [] [ Γ > Δ > [] |- [(a1 ---> a2) ---> a3 ]@l ] ->
+ ND Rule [Γ > Δ > Σ,,[a1 @@ l] |- [a2]@l ]
+ [Γ > Δ > Σ |- [a3]@l ].
+ intro pf.
+ eapply nd_comp; [ eapply nd_rule; eapply RLam | idtac ].
+ set (fToC1 pf) as pf'.
+ apply boost.
+ apply pf'.
+ Defined.
+
+ Section coqPassCoreToCore.
+ Context
+ (do_flatten : bool)
+ (do_skolemize : bool)
+ (hetmet_brak : CoreVar)
+ (hetmet_esc : CoreVar)
+ (hetmet_kappa : WeakExprVar)
+ (hetmet_kappa_app : WeakExprVar)
+ (uniqueSupply : UniqSupply)
+ (lbinds:list (@CoreBind CoreVar))
+ (hetmet_PGArrowTyCon : TyFun)
+ (hetmet_PGArrow_unit_TyCon : TyFun)
+ (hetmet_PGArrow_tensor_TyCon : TyFun)
+ (hetmet_PGArrow_exponent_TyCon : TyFun)
+ (hetmet_pga_id : CoreVar)
+ (hetmet_pga_comp : CoreVar)
+ (hetmet_pga_first : CoreVar)
+ (hetmet_pga_second : CoreVar)
+ (hetmet_pga_cancell : CoreVar)
+ (hetmet_pga_cancelr : CoreVar)
+ (hetmet_pga_uncancell : CoreVar)
+ (hetmet_pga_uncancelr : CoreVar)
+ (hetmet_pga_assoc : CoreVar)
+ (hetmet_pga_unassoc : CoreVar)
+ (hetmet_pga_copy : CoreVar)
+ (hetmet_pga_drop : CoreVar)
+ (hetmet_pga_swap : CoreVar)
+ (hetmet_pga_applyl : CoreVar)
+ (hetmet_pga_applyr : CoreVar)
+ (hetmet_pga_curryl : CoreVar)
+ (hetmet_pga_curryr : CoreVar)
+ (hetmet_pga_loopl : CoreVar)
+ (hetmet_pga_loopr : CoreVar)
+ (hetmet_pga_kappa : CoreVar)
+ .
+
+
+ Definition ga_unit TV (ec:RawHaskType TV ECKind) : RawHaskType TV ★ :=
+ @TyFunApp TV hetmet_PGArrow_unit_TyCon (ECKind::nil) ★ (TyFunApp_cons _ _ ec TyFunApp_nil).
+
+ Definition ga_prod TV (ec:RawHaskType TV ECKind) (a b:RawHaskType TV ★) : RawHaskType TV ★ :=
+ (@TyFunApp TV
+ hetmet_PGArrow_tensor_TyCon
+ (ECKind::★ ::★ ::nil) ★
+ (TyFunApp_cons _ _ ec
+ (TyFunApp_cons _ _ a
+ (TyFunApp_cons _ _ b
+ TyFunApp_nil)))).
+
+ Definition ga_type {TV}(a:RawHaskType TV ECKind)(b c:RawHaskType TV ★) : RawHaskType TV ★ :=
+ TApp (TApp (TApp (@TyFunApp TV
+ hetmet_PGArrowTyCon
+ nil _ TyFunApp_nil) a) b) c.
+
+ Definition ga := @ga_mk ga_unit ga_prod (@ga_type).
+
+ Definition ga_type' {Γ}(a:HaskType Γ ECKind)(b c:HaskType Γ ★) : HaskType Γ ★ :=
+ fun TV ite => TApp (TApp (TApp (@TyFunApp TV
+ hetmet_PGArrowTyCon
+ nil _ TyFunApp_nil) (a TV ite)) (b TV ite)) (c TV ite).
+
+ Definition mkGlob2' {Γ}{κ₁}{κ₂}(f:HaskType Γ κ₁ -> HaskType Γ κ₂ -> HaskType Γ ★) :
+ IList Kind (fun κ : Kind => HaskType Γ κ) (κ₁::κ₂::nil) -> HaskType Γ ★.
+ intros.
+ inversion X; subst.
+ inversion X1; subst.
+ apply f; auto.
+ Defined.
+
+ Definition mkGlob2 {Γ}{Δ}{l}{κ₁}{κ₂}(cv:CoreVar)(f:HaskType Γ κ₁ -> HaskType Γ κ₂ -> HaskType Γ ★) x y
+ : ND Rule [] [ Γ > Δ > [] |- [f x y ]@l ].
+ apply nd_rule.
+ refine (@RGlobal Γ Δ l
+ {| glob_wv := coreVarToWeakExprVarOrError cv
+ ; glob_kinds := κ₁ :: κ₂ :: nil
+ ; glob_tf := mkGlob2'(Γ:=Γ) f
+ |} (ICons _ _ x (ICons _ _ y INil))).
+ Defined.
+
+ Definition mkGlob3' {Γ}{κ₁}{κ₂}{κ₃}(f:HaskType Γ κ₁ -> HaskType Γ κ₂ -> HaskType Γ κ₃ -> HaskType Γ ★) :
+ IList Kind (fun κ : Kind => HaskType Γ κ) (κ₁::κ₂::κ₃::nil) -> HaskType Γ ★.
+ intros.
+ inversion X; subst.
+ inversion X1; subst.
+ inversion X3; subst.
+ apply f; auto.
+ Defined.
+
+ Definition mkGlob3 {Γ}{Δ}{l}{κ₁}{κ₂}{κ₃}(cv:CoreVar)(f:HaskType Γ κ₁ -> HaskType Γ κ₂ -> HaskType Γ κ₃ -> HaskType Γ ★) x y z
+ : ND Rule [] [ Γ > Δ > [] |- [f x y z ]@l ].
+ apply nd_rule.
+ refine (@RGlobal Γ Δ l
+ {| glob_wv := coreVarToWeakExprVarOrError cv
+ ; glob_kinds := κ₁ :: κ₂ :: κ₃ :: nil
+ ; glob_tf := mkGlob3'(Γ:=Γ) f
+ |} (ICons _ _ x (ICons _ _ y (ICons _ _ z INil)))).
+ Defined.
+
+ Definition mkGlob4' {Γ}{κ₁}{κ₂}{κ₃}{κ₄}(f:HaskType Γ κ₁ -> HaskType Γ κ₂ -> HaskType Γ κ₃ -> HaskType Γ κ₄ -> HaskType Γ ★) :
+ IList Kind (fun κ : Kind => HaskType Γ κ) (κ₁::κ₂::κ₃::κ₄::nil) -> HaskType Γ ★.
+ intros.
+ inversion X; subst.
+ inversion X1; subst.
+ inversion X3; subst.
+ inversion X5; subst.
+ apply f; auto.
+ Defined.
+
+ Definition mkGlob4 {Γ}{Δ}{l}{κ₁}{κ₂}{κ₃}{κ₄}(cv:CoreVar)(f:HaskType Γ κ₁ -> HaskType Γ κ₂ -> HaskType Γ κ₃ -> HaskType Γ κ₄ -> HaskType Γ ★) x y z q
+ : ND Rule [] [ Γ > Δ > [] |- [f x y z q ] @l].
+ apply nd_rule.
+ refine (@RGlobal Γ Δ l
+ {| glob_wv := coreVarToWeakExprVarOrError cv
+ ; glob_kinds := κ₁ :: κ₂ :: κ₃ :: κ₄ :: nil
+ ; glob_tf := mkGlob4'(Γ:=Γ) f
+ |} (ICons _ _ x (ICons _ _ y (ICons _ _ z (ICons _ _ q INil))))).
+ Defined.
+
+ Definition gat {Γ} ec (x:Tree ??(HaskType Γ ★)) := @ga_mk_tree ga_unit ga_prod _ ec x.
+
+ Instance my_ga : garrow ga_unit ga_prod (@ga_type) :=
+ { ga_id := fun Γ Δ ec l a => mkGlob2 hetmet_pga_id (fun ec a => ga_type' ec a a) ec (gat ec a)
+ ; ga_cancelr := fun Γ Δ ec l a => mkGlob2 hetmet_pga_cancelr (fun ec a => ga_type' ec _ a) ec (gat ec a)
+ ; ga_cancell := fun Γ Δ ec l a => mkGlob2 hetmet_pga_cancell (fun ec a => ga_type' ec _ a) ec (gat ec a)
+ ; ga_uncancelr := fun Γ Δ ec l a => mkGlob2 hetmet_pga_uncancelr (fun ec a => ga_type' ec a _) ec (gat ec a)
+ ; ga_uncancell := fun Γ Δ ec l a => mkGlob2 hetmet_pga_uncancell (fun ec a => ga_type' ec a _) ec (gat ec a)
+ ; ga_assoc := fun Γ Δ ec l a b c => mkGlob4 hetmet_pga_assoc (fun ec a b c => ga_type' ec _ _) ec (gat ec a) (gat ec b) (gat ec c)
+ ; ga_unassoc := fun Γ Δ ec l a b c => mkGlob4 hetmet_pga_unassoc (fun ec a b c => ga_type' ec _ _) ec (gat ec a) (gat ec b) (gat ec c)
+ ; ga_swap := fun Γ Δ ec l a b => mkGlob3 hetmet_pga_swap (fun ec a b => ga_type' ec _ _) ec (gat ec a) (gat ec b)
+ ; ga_drop := fun Γ Δ ec l a => mkGlob2 hetmet_pga_drop (fun ec a => ga_type' ec _ _) ec (gat ec a)
+ ; ga_copy := fun Γ Δ ec l a => mkGlob2 hetmet_pga_copy (fun ec a => ga_type' ec _ _) ec (gat ec a)
+ ; ga_first := fun Γ Δ ec l a b x => fToC1 (mkGlob4 hetmet_pga_first (fun ec a b c => _) ec (gat ec a) (gat ec b) (gat ec x))
+ ; ga_second := fun Γ Δ ec l a b x => fToC1 (mkGlob4 hetmet_pga_second (fun ec a b c => _) ec (gat ec a) (gat ec b) (gat ec x))
+ ; ga_comp := fun Γ Δ ec l a b c => fToC2 (mkGlob4 hetmet_pga_comp (fun ec a b c => _) ec (gat ec a) (gat ec b) (gat ec c))
+ ; ga_loopl := fun Γ Δ ec l a b x => fToC1 (mkGlob4 hetmet_pga_loopl (fun ec a b c => _) ec (gat ec a) (gat ec b) (gat ec x))
+ ; ga_loopr := fun Γ Δ ec l a b x => fToC1 (mkGlob4 hetmet_pga_loopr (fun ec a b c => _) ec (gat ec a) (gat ec b) (gat ec x))
+
+ ; ga_curry := fun Γ Δ ec l a => Prelude_error "ga_curry"
+
+ ; ga_apply := fun Γ Δ ec l a => Prelude_error "ga_apply"
+ ; ga_lit := fun Γ Δ ec l a => Prelude_error "ga_lit"
+(* ; ga_lit := fun Γ Δ ec l a => nd_rule (RGlobal _ _ _ _ (coreVarToWeakExprVarOrError hetmet_pga_lit))*)
+ ; ga_kappa := fun Γ Δ ec l a b c Σ =>
+ fToCx Σ (mkGlob4 hetmet_pga_kappa (fun ec a b c => _) ec (gat ec a) (gat ec b) (gat ec c))
+ }.
+
+ Definition hetmet_brak' := coreVarToWeakExprVarOrError hetmet_brak.
+ Definition hetmet_esc' := coreVarToWeakExprVarOrError hetmet_esc.
+ Definition hetmet_kappa' := coreVarToWeakExprVarOrError hetmet_kappa.
+ Definition hetmet_kappa_app' := coreVarToWeakExprVarOrError hetmet_kappa_app.
+
+ Definition coreToCoreExpr' (cex:@CoreExpr CoreVar) : ???(@CoreExpr CoreVar) :=
+ addErrorMessage ("input CoreSyn: " +++ toString cex)
+ (addErrorMessage ("input CoreType: " +++ toString (coreTypeOfCoreExpr cex)) (
+ coreExprToWeakExpr cex >>= fun we =>
addErrorMessage ("WeakExpr: " +++ toString we)
((addErrorMessage ("CoreType of WeakExpr: " +++ toString (coreTypeOfCoreExpr (weakExprToCoreExpr we)))
((weakTypeOfWeakExpr we) >>= fun t =>
((weakExprToStrongExpr Γ Δ φ ψ ξ (fun _ => true) τ nil we) >>= fun e =>
(addErrorMessage ("HaskStrong...")
- (let haskProof := @expr2proof _ _ _ _ _ _ e
- in (* insert HaskProof-to-HaskProof manipulations here *)
- OK ((@proof2expr nat _ FreshNat _ _ _ _ (fun _ => Prelude_error "unbound unique") _ haskProof) O)
- >>= fun e' =>
- (snd e') >>= fun e'' =>
- strongExprToWeakExpr hetmet_brak hetmet_esc mkWeakTypeVar mkWeakCoerVar mkWeakExprVar uniqueSupply
- (projT2 e'') INil
- >>= fun q =>
- OK (weakExprToCoreExpr q)
- )))))))))).
+ (if do_skolemize
+ then
+ (let haskProof := skolemize_and_flatten_proof my_ga (@expr2proof _ _ _ _ _ _ _ e)
+ in (* insert HaskProof-to-HaskProof manipulations here *)
+ OK ((@proof2expr nat _ FreshNat _ _ (flatten_type τ) nil _
+ (fun _ => Prelude_error "unbound unique") _ haskProof) O)
+ >>= fun e' => (snd e') >>= fun e'' =>
+ strongExprToWeakExpr hetmet_brak' hetmet_esc' (*hetmet_kappa' hetmet_kappa_app'*)
+ mkWeakTypeVar mkWeakCoerVar mkWeakExprVar uniqueSupply
+ (projT2 e'') INil
+ >>= fun q => OK (weakExprToCoreExpr q))
+ else (if do_flatten
+ then
+ (let haskProof := flatten_proof (@expr2proof _ _ _ _ _ _ _ e)
+ in (* insert HaskProof-to-HaskProof manipulations here *)
+ OK ((@proof2expr nat _ FreshNat _ _ τ nil _
+ (fun _ => Prelude_error "unbound unique") _ haskProof) O)
+ >>= fun e' => (snd e') >>= fun e'' =>
+ strongExprToWeakExpr hetmet_brak' hetmet_esc' (*hetmet_kappa' hetmet_kappa_app'*)
+ mkWeakTypeVar mkWeakCoerVar mkWeakExprVar uniqueSupply
+ (projT2 e'') INil
+ >>= fun q => OK (weakExprToCoreExpr q))
+ else
+ (let haskProof := @expr2proof _ _ _ _ _ _ _ e
+ in (* insert HaskProof-to-HaskProof manipulations here *)
+ OK ((@proof2expr nat _ FreshNat _ _ τ nil _
+ (fun _ => Prelude_error "unbound unique") _ haskProof) O)
+ >>= fun e' => (snd e') >>= fun e'' =>
+ strongExprToWeakExpr hetmet_brak' hetmet_esc' (*hetmet_kappa' hetmet_kappa_app'*)
+ mkWeakTypeVar mkWeakCoerVar mkWeakExprVar uniqueSupply
+ (projT2 e'') INil
+ >>= fun q => OK (weakExprToCoreExpr q))))
+ ))))))))).
Definition coreToCoreExpr (ce:@CoreExpr CoreVar) : (@CoreExpr CoreVar) :=
match coreToCoreExpr' ce with
| OK x => x
| Error s => Prelude_error s
end.
-
+
Definition coreToCoreBind (binds:@CoreBind CoreVar) : @CoreBind CoreVar :=
match binds with
- | CoreNonRec v e => CoreNonRec v (coreToCoreExpr e)
+ | CoreNonRec v e => let e' := coreToCoreExpr e in CoreNonRec (setVarType v (coreTypeOfCoreExpr e')) e'
+
| CoreRec lbe => CoreRec (map (fun ve => match ve with (v,e) => (v,coreToCoreExpr e) end) lbe)
+ (* FIXME: doesn't deal with the case where top level recursive binds change type *)
+(*
+ match coreToCoreExpr (CoreELet lbe) (CoreELit HaskMachNullAddr) with
+ | CoreELet (CoreRec lbe') => lbe'
+ | x => Prelude_error
+ ("coreToCoreExpr was given a letrec, " +++
+ "but returned something that wasn't a letrec: " +++ toString x)
+ end
+*)
end.
-
+
Definition coqPassCoreToCore' (lbinds:list (@CoreBind CoreVar)) : list (@CoreBind CoreVar) :=
map coreToCoreBind lbinds.
- End CoreToCore.
+ End coqPassCoreToCore.
- Definition coqPassCoreToCore
- (hetmet_brak : CoreVar)
- (hetmet_esc : CoreVar)
+ Notation "a >>= b" := (@CoreMbind _ _ a b).
+
+ Definition coqPassCoreToCore
+ (do_flatten : bool)
+ (do_skolemize : bool)
+ (dsLookupVar : string -> string -> CoreM CoreVar)
+ (dsLookupTyc : string -> string -> CoreM TyFun)
(uniqueSupply : UniqSupply)
- (lbinds:list (@CoreBind CoreVar)) : list (@CoreBind CoreVar) :=
- match coreVarToWeakVar hetmet_brak with
- | WExprVar hetmet_brak' => match coreVarToWeakVar hetmet_esc with
- | WExprVar hetmet_esc' => coqPassCoreToCore' hetmet_brak' hetmet_esc' uniqueSupply lbinds
- | _ => Prelude_error "IMPOSSIBLE"
- end
- | _ => Prelude_error "IMPOSSIBLE"
- end.
+ (lbinds : list (@CoreBind CoreVar))
+ : CoreM (list (@CoreBind CoreVar)) :=
+ dsLookupVar "GHC.HetMet.CodeTypes" "hetmet_brak" >>= fun hetmet_brak =>
+ dsLookupVar "GHC.HetMet.CodeTypes" "hetmet_esc" >>= fun hetmet_esc =>
+ dsLookupVar "GHC.HetMet.CodeTypes" "hetmet_kappa" >>= fun hetmet_kappa =>
+ dsLookupVar "GHC.HetMet.CodeTypes" "hetmet_kappa_app" >>= fun hetmet_kappa_app =>
+ dsLookupTyc "GHC.HetMet.Private" "PGArrow" >>= fun hetmet_PGArrow =>
+ dsLookupTyc "Control.GArrow" "GArrowUnit" >>= fun hetmet_PGArrow_unit =>
+ dsLookupTyc "Control.GArrow" "GArrowTensor" >>= fun hetmet_PGArrow_tensor =>
+ dsLookupTyc "Control.GArrow" "GArrowExponent" >>= fun hetmet_PGArrow_exponent =>
+ dsLookupVar "GHC.HetMet.Private" "pga_id" >>= fun hetmet_pga_id =>
+ dsLookupVar "GHC.HetMet.Private" "pga_comp" >>= fun hetmet_pga_comp =>
+ dsLookupVar "GHC.HetMet.Private" "pga_first" >>= fun hetmet_pga_first =>
+ dsLookupVar "GHC.HetMet.Private" "pga_second" >>= fun hetmet_pga_second =>
+ dsLookupVar "GHC.HetMet.Private" "pga_cancell" >>= fun hetmet_pga_cancell =>
+ dsLookupVar "GHC.HetMet.Private" "pga_cancelr" >>= fun hetmet_pga_cancelr =>
+ dsLookupVar "GHC.HetMet.Private" "pga_uncancell" >>= fun hetmet_pga_uncancell =>
+ dsLookupVar "GHC.HetMet.Private" "pga_uncancelr" >>= fun hetmet_pga_uncancelr =>
+ dsLookupVar "GHC.HetMet.Private" "pga_assoc" >>= fun hetmet_pga_assoc =>
+ dsLookupVar "GHC.HetMet.Private" "pga_unassoc" >>= fun hetmet_pga_unassoc =>
+ dsLookupVar "GHC.HetMet.Private" "pga_copy" >>= fun hetmet_pga_copy =>
+ dsLookupVar "GHC.HetMet.Private" "pga_drop" >>= fun hetmet_pga_drop =>
+ dsLookupVar "GHC.HetMet.Private" "pga_swap" >>= fun hetmet_pga_swap =>
+ dsLookupVar "GHC.HetMet.Private" "pga_applyl" >>= fun hetmet_pga_applyl =>
+ dsLookupVar "GHC.HetMet.Private" "pga_applyr" >>= fun hetmet_pga_applyr =>
+ dsLookupVar "GHC.HetMet.Private" "pga_curryl" >>= fun hetmet_pga_curryl =>
+ dsLookupVar "GHC.HetMet.Private" "pga_curryr" >>= fun hetmet_pga_curryr =>
+ dsLookupVar "GHC.HetMet.Private" "pga_loopl" >>= fun hetmet_pga_loopl =>
+ dsLookupVar "GHC.HetMet.Private" "pga_loopr" >>= fun hetmet_pga_loopr =>
+ dsLookupVar "GHC.HetMet.Private" "pga_kappa" >>= fun hetmet_pga_kappa =>
+
+ CoreMreturn
+ (coqPassCoreToCore'
+ do_flatten
+ do_skolemize
+ hetmet_brak
+ hetmet_esc
+ (*
+ hetmet_kappa
+ hetmet_kappa_app
+ *)
+ uniqueSupply
+ hetmet_PGArrow
+ hetmet_PGArrow_unit
+ hetmet_PGArrow_tensor
+(* hetmet_PGArrow_exponent_TyCon*)
+ hetmet_pga_id
+ hetmet_pga_comp
+ hetmet_pga_first
+ hetmet_pga_second
+ hetmet_pga_cancell
+ hetmet_pga_cancelr
+ hetmet_pga_uncancell
+ hetmet_pga_uncancelr
+ hetmet_pga_assoc
+ hetmet_pga_unassoc
+ hetmet_pga_copy
+ hetmet_pga_drop
+ hetmet_pga_swap
+ hetmet_pga_loopl
+ hetmet_pga_loopr
+ hetmet_pga_kappa
+ lbinds
+ (*
+ hetmet_pga_applyl
+ hetmet_pga_applyr
+ hetmet_pga_curryl
+ *)
+ )
+ .
End core2proof.
}.
Coercion eqd_type : EqDecidable >-> Sortclass.
+Instance EqDecidableOption (T:Type)(EQDT:EqDecidable T) : EqDecidable ??T.
+ apply Build_EqDecidable.
+ intros.
+ destruct v1;
+ destruct v2.
+ destruct (eqd_dec t t0).
+ subst.
+ left; auto.
+ right.
+ unfold not; intros.
+ inversion H.
+ subst.
+ apply n.
+ auto.
+ right; unfold not; intro; inversion H.
+ right; unfold not; intro; inversion H.
+ left; auto.
+ Defined.
Class ToString (T:Type) := { toString : T -> string }.
Instance StringToString : ToString string := { toString := fun x => x }.
end.
Definition treeDecomposition {D T:Type} (mapLeaf:T->D) (mergeBranches:D->D->D) :=
forall d:D, { tt:Tree T & d = treeReduce mapLeaf mergeBranches tt }.
+Lemma mapOptionTree_distributes
+ : forall T R (a b:Tree ??T) (f:T->R),
+ mapOptionTree f (a,,b) = (mapOptionTree f a),,(mapOptionTree f b).
+ reflexivity.
+ Qed.
+
+Fixpoint reduceTree {T}(unit:T)(merge:T -> T -> T)(tt:Tree ??T) : T :=
+ match tt with
+ | T_Leaf None => unit
+ | T_Leaf (Some x) => x
+ | T_Branch b1 b2 => merge (reduceTree unit merge b1) (reduceTree unit merge b2)
+ end.
Lemma tree_dec_eq :
forall {Q}(t1 t2:Tree ??Q),
| (a::al) => f a /\ mapProp f al
end.
+
+(* delete the n^th element of a list *)
+Definition list_del : forall {T:Type} (l:list T) (n:nat)(pf:lt n (length l)), list T.
+ refine (fix list_del {T:Type} (l:list T) (n:nat) : lt n (length l) -> list T :=
+ match l as L return lt n (length L) -> list T with
+ | nil => _
+ | a::b => match n with
+ | O => fun _ => b
+ | S n' => fun pf => (fun list_del' => _) (list_del _ b n')
+ end
+ end).
+ intro pf.
+ simpl in pf.
+ assert False.
+ inversion pf.
+ inversion H.
+
+ simpl in *.
+ apply list_del'.
+ omega.
+ Defined.
+
+Definition list_get : forall {T:Type} (l:list T) (n:nat), lt n (length l) -> T.
+ refine (fix list_get {T:Type} (l:list T) (n:nat) : lt n (length l) -> T :=
+ match l as L return lt n (length L) -> T with
+ | nil => _
+ | a::b => match n with
+ | O => fun _ => a
+ | S n' => fun pf => (fun list_get' => _) (list_get _ b n')
+ end
+ end).
+ intro pf.
+ assert False.
+ inversion pf.
+ inversion H.
+
+ simpl in *.
+ apply list_get'.
+ omega.
+ Defined.
+
+Fixpoint list_ins (n:nat) {T:Type} (t:T) (l:list T) : list T :=
+ match n with
+ | O => t::l
+ | S n' => match l with
+ | nil => t::nil
+ | a::b => a::(list_ins n' t b)
+ end
+ end.
+
+Lemma list_ins_nil : forall T n x, @list_ins n T x nil = x::nil.
+ intros.
+ destruct n; auto.
+ Qed.
+
+Fixpoint list_take {T:Type}(l:list T)(n:nat) :=
+ match n with
+ | O => nil
+ | S n' => match l with
+ | nil => nil
+ | a::b => a::(list_take b n')
+ end
+ end.
+
+Fixpoint list_drop {T:Type}(l:list T)(n:nat) :=
+ match n with
+ | O => l
+ | S n' => match l with
+ | nil => nil
+ | a::b => list_drop b n'
+ end
+ end.
+
+Lemma list_ins_app T n κ : forall Γ, @list_ins n T κ Γ = app (list_take Γ n) (κ::(list_drop Γ n)).
+ induction n.
+ simpl.
+ intros.
+ destruct Γ; auto.
+ intro Γ.
+ destruct Γ.
+ reflexivity.
+ simpl.
+ rewrite <- IHn.
+ reflexivity.
+ Qed.
+
+Lemma list_take_drop T l : forall n, app (@list_take T l n) (list_drop l n) = l.
+ induction l; auto.
+ simpl.
+ destruct n; auto.
+ simpl.
+ destruct n.
+ reflexivity.
+ simpl.
+ rewrite IHl.
+ reflexivity.
+ Qed.
+
Lemma map_id : forall A (l:list A), (map (fun x:A => x) l) = l.
induction l.
auto.
apply eqd_dec.
Defined.
+Fixpoint listToString {T:Type}{tst:ToString T}(l:list T) : string :=
+ match l with
+ | nil => "nil"
+ | a::b => (toString a) +++ "::" +++ listToString b
+ end.
+
+Instance ListToString {T:Type}{tst:ToString T} : ToString (list T) :=
+ { toString := @listToString _ _ }.
+
+
+(*******************************************************************************)
+(* Tree Flags *)
+
+(* TreeFlags is effectively a tree of booleans whose shape matches that of another tree *)
+Inductive TreeFlags {T:Type} : Tree T -> Type :=
+| tf_leaf_true : forall x, TreeFlags (T_Leaf x)
+| tf_leaf_false : forall x, TreeFlags (T_Leaf x)
+| tf_branch : forall b1 b2, TreeFlags b1 -> TreeFlags b2 -> TreeFlags (b1,,b2).
+
+(* If flags are calculated using a local condition, this will build the flags *)
+Fixpoint mkFlags {T}(f:T -> bool)(t:Tree T) : TreeFlags t :=
+ match t as T return TreeFlags T with
+ | T_Leaf x => if f x then tf_leaf_true x else tf_leaf_false x
+ | T_Branch b1 b2 => tf_branch _ _ (mkFlags f b1) (mkFlags f b2)
+ end.
+
+(* takeT and dropT are not exact inverses! *)
+
+(* drop replaces each leaf where the flag is set with a [] *)
+Fixpoint dropT {T}{Σ:Tree ??T}(tf:TreeFlags Σ) : Tree ??T :=
+ match tf with
+ | tf_leaf_true x => []
+ | tf_leaf_false x => Σ
+ | tf_branch b1 b2 tb1 tb2 => (dropT tb1),,(dropT tb2)
+ end.
+
+(* takeT returns only those leaves for which the flag is set; all others are omitted entirely from the tree *)
+Fixpoint takeT {T}{Σ:Tree T}(tf:TreeFlags Σ) : ??(Tree T) :=
+ match tf with
+ | tf_leaf_true x => Some Σ
+ | tf_leaf_false x => None
+ | tf_branch b1 b2 tb1 tb2 =>
+ match takeT tb1 with
+ | None => takeT tb2
+ | Some b1' => match takeT tb2 with
+ | None => Some b1'
+ | Some b2' => Some (b1',,b2')
+ end
+ end
+ end.
+
+Definition takeT' {T}{Σ:Tree ??T}(tf:TreeFlags Σ) : Tree ??T :=
+ match takeT tf with
+ | None => []
+ | Some x => x
+ end.
+
+(* lift a function T->bool to a function (option T)->bool by yielding (None |-> b) *)
+Definition liftBoolFunc {T}(b:bool)(f:T -> bool) : ??T -> bool :=
+ fun t =>
+ match t with
+ | None => b
+ | Some x => f x
+ end.
+
+(* decidable quality on a tree of elements which have decidable equality *)
+Definition tree_eq_dec : forall {T:Type}(l1 l2:Tree T)(dec:forall t1 t2:T, sumbool (eq t1 t2) (not (eq t1 t2))),
+ sumbool (eq l1 l2) (not (eq l1 l2)).
+ intro T.
+ intro l1.
+ induction l1; intros.
+ destruct l2.
+ destruct (dec a t).
+ subst.
+ left; auto.
+ right; unfold not; intro; apply n; inversion H; auto.
+ right.
+ unfold not; intro.
+ inversion H.
+
+ destruct l2.
+ right; unfold not; intro; inversion H.
+ destruct (IHl1_1 l2_1 dec);
+ destruct (IHl1_2 l2_2 dec); subst.
+ left; auto.
+ right.
+ unfold not; intro.
+ inversion H; subst.
+ apply n; auto.
+ right.
+ unfold not; intro.
+ inversion H; subst.
+ apply n; auto.
+ right.
+ unfold not; intro.
+ inversion H; subst.
+ apply n; auto.
+ Defined.
+
+Instance EqDecidableTree {T:Type}(eqd:EqDecidable T) : EqDecidable (Tree T).
+ apply Build_EqDecidable.
+ intros.
+ apply tree_eq_dec.
+ apply eqd_dec.
+ Defined.
+
(*******************************************************************************)
(* Length-Indexed Lists *)
inversion v; subst; auto.
Defined.
+Lemma ilist_app {T}{F}{l1:list T}(v1:IList T F l1) : forall {l2:list T}(v2:IList T F l2), IList T F (app l1 l2).
+ induction l1; auto.
+ intros.
+ inversion v1.
+ subst.
+ simpl.
+ apply ICons.
+ apply X.
+ apply IHl1; auto.
+ Defined.
+
+Definition ilist_ins {T}{F}{l:list T} z (fz:F z) : forall n (il:IList T F l), IList T F (list_ins n z l).
+ induction l; simpl.
+ intros.
+ destruct n; simpl.
+ apply ICons; [ apply fz | apply INil ].
+ apply ICons; [ apply fz | apply INil ].
+ intros.
+ destruct n; simpl.
+ apply ICons; auto.
+ inversion il; subst.
+ apply ICons; auto.
+ Defined.
+
Fixpoint ilist_to_list {T}{Z}{l:list T}(il:IList T (fun _ => Z) l) : list Z :=
match il with
| INil => nil
Definition map2 {A}{B}(f:A->B)(t:A*A) : (B*B) := ((f (fst t)), (f (snd t))).
+(* boolean "not" *)
+Definition bnot (b:bool) : bool := if b then false else true.
+Definition band (b1 b2:bool) : bool := if b1 then b2 else false.
+Definition bor (b1 b2:bool) : bool := if b1 then true else b2.
(* string stuff *)
Variable eol : string.
Notation "a >>=[ S ] b" := (@orErrorBindWithMessage _ a _ b S) (at level 20).
Definition addErrorMessage s {T} (x:OrError T) :=
- x >>=[ s ] (fun y => OK y).
+ x >>=[ eol +++ eol +++ s ] (fun y => OK y).
Inductive Indexed {T:Type}(f:T -> Type) : ???T -> Type :=
| Indexed_Error : forall error_message:string, Indexed f (Error error_message)
apply (Error (error_message (length l) n)).
Defined.
+(* this makes a type function application, ensuring not to oversaturate it (though if it was undersaturated we can't fix that) *)
+Fixpoint split_list {T}(l:list T)(n:nat) : ???(list T * list T) :=
+ match n with
+ | O => OK (nil , l)
+ | S n' => match l with
+ | nil => Error "take_list failed"
+ | h::t => split_list t n' >>= fun t' => let (t1,t2) := t' in OK ((h::t1),t2)
+ end
+ end.
+
(* Uniques *)
Variable UniqSupply : Type. Extract Inlined Constant UniqSupply => "UniqSupply.UniqSupply".
Variable Unique : Type. Extract Inlined Constant Unique => "Unique.Unique".
Require Import General.
Require Import Coq.Strings.String.
Require Import HaskKinds.
-Require Import HaskLiteralsAndTyCons.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
Require Import HaskCoreTypes.
Require Import HaskCoreVars.
| CoreECast : CoreExpr -> CoreCoercion -> CoreExpr
| CoreENote : Note -> CoreExpr -> CoreExpr
| CoreEType : CoreType -> CoreExpr
+| CoreECoercion : CoreCoercion -> CoreExpr
with CoreBind {b:Type} :=
| CoreNonRec : b -> CoreExpr -> CoreBind
| CoreRec : list (b * CoreExpr ) -> CoreBind.
"CoreSyn.Case"
"CoreSyn.Cast"
"CoreSyn.Note"
- "CoreSyn.Type" ].
+ "CoreSyn.Type"
+ "CoreSyn.Coercion"
+ ].
Extract Inductive CoreBind =>
"CoreSyn.Bind" [ "CoreSyn.NonRec" "CoreSyn.Rec" ].
Require Import Coq.Lists.List.
Require Import General.
Require Import HaskKinds.
-Require Import HaskLiteralsAndTyCons.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
Require Import HaskCoreVars.
Require Import HaskCoreTypes.
Require Import HaskCore.
Require Import HaskWeakTypes.
Require Import HaskWeak.
-Variable tyConOrTyFun : CoreTyCon -> sum TyCon TyFun. Extract Inlined Constant tyConOrTyFun => "tyConOrTyFun".
-Variable coreViewDeep : CoreType -> CoreType. Extract Inlined Constant coreViewDeep => "coreViewDeep".
-Variable coreCoercionToWeakCoercion : CoreCoercion -> WeakCoercion.
- Extract Inlined Constant coreCoercionToWeakCoercion => "coreCoercionToWeakCoercion".
+Variable tyConOrTyFun : CoreTyCon -> sum TyCon TyFun. Extract Inlined Constant tyConOrTyFun => "tyConOrTyFun".
+Variable coreViewDeep : CoreType -> CoreType. Extract Inlined Constant coreViewDeep => "coreViewDeep".
+Variable coercionKind : CoreCoercion -> (CoreType * CoreType).
+ Extract Inlined Constant coercionKind => "(\x -> Pair.unPair (Coercion.coercionKind x))".
(* extracts the Name from a CoreVar *)
Variable coreVarCoreName : CoreVar -> CoreName. Extract Inlined Constant coreVarCoreName => "Var.varName".
Variable hetmet_brak_name : CoreName. Extract Inlined Constant hetmet_brak_name => "PrelNames.hetmet_brak_name".
Variable hetmet_esc_name : CoreName. Extract Inlined Constant hetmet_esc_name => "PrelNames.hetmet_esc_name".
Variable hetmet_csp_name : CoreName. Extract Inlined Constant hetmet_csp_name => "PrelNames.hetmet_csp_name".
+Variable hetmet_kappa_name : CoreName. Extract Inlined Constant hetmet_kappa_name => "PrelNames.hetmet_kappa_name".
+Variable hetmet_kappa_app_name: CoreName.
+Extract Inlined Constant hetmet_kappa_app_name => "PrelNames.hetmet_kappa_app_name".
+
+Definition mkTyFunApplication (tf:TyFun)(lwt:list WeakType) : ???WeakType :=
+ split_list lwt (length (fst (tyFunKind tf))) >>=
+ fun argsrest =>
+ let (args,rest) := argsrest in
+ OK (fold_left (fun x y => WAppTy x y) rest (WTyFunApp tf args)).
+
+(* a hack to evade the guardedness check of Fixpoint *)
+Variable coreTypeToWeakTypeCheat' : CoreType -> ???WeakType.
+Extract Inlined Constant coreTypeToWeakTypeCheat' => "coreTypeToWeakType'".
Fixpoint coreTypeToWeakType' (ct:CoreType) : ???WeakType :=
match ct with
| TyVarTy cv => match coreVarToWeakVar cv with
- | WExprVar _ => Error "encountered expression variable in a type"
- | WTypeVar tv => OK (WTyVarTy tv)
- | WCoerVar _ => Error "encountered coercion variable in a type"
+ | CVTWVR_EVar ct => Error "encountered expression variable in a type"
+ | CVTWVR_TyVar k => OK (WTyVarTy (weakTypeVar cv k))
+ | CVTWVR_CoVar t1 t2 => Error "encountered coercion variable in a type"
end
| AppTy t1 t2 => coreTypeToWeakType' t2 >>= fun t2' => coreTypeToWeakType' t1 >>= fun t1' => OK (WAppTy t1' t2')
| a::b => coreTypeToWeakType' a >>= fun a' => rec b >>= fun b' => OK (a'::b')
end) lct)
in match tyConOrTyFun tc_ with
- | inr tf => recurse >>= fun recurse' => OK (WTyFunApp tf recurse')
+ | inr tf => recurse >>= fun recurse' => mkTyFunApplication tf recurse'
| inl tc => if eqd_dec tc ModalBoxTyCon
then match lct with
| ((TyVarTy ec)::tbody::nil) =>
match coreVarToWeakVar ec with
- | WTypeVar ec' => coreTypeToWeakType' tbody >>= fun tbody' => OK (WCodeTy ec' tbody')
- | WExprVar _ => Error "encountered expression variable in a modal box type"
- | WCoerVar _ => Error "encountered coercion variable in a modal box type"
+ | CVTWVR_EVar ct => Error "encountered expression variable in a modal box type"
+ | CVTWVR_CoVar t1 t2 => Error "encountered coercion variable in a modal box type"
+ | CVTWVR_TyVar k => coreTypeToWeakType' tbody >>= fun tbody' =>
+ OK (WCodeTy (weakTypeVar ec k) tbody')
end
- | _ => Error ("mis-applied modal box tycon: " +++ toString ct)
+ | _ => Error ("mis-applied modal box tycon: " +++ toString ct)
end
else let tc' := if eqd_dec tc ArrowTyCon
then WFunTyCon
coreTypeToWeakType' t2 >>= fun t2' =>
OK (WAppTy (WAppTy WFunTyCon t1') t2')
| ForAllTy cv t => match coreVarToWeakVar cv with
- | WExprVar _ => Error "encountered expression variable in a type"
- | WTypeVar tv => coreTypeToWeakType' t >>= fun t' => OK (WForAllTy tv t')
- | WCoerVar _ => Error "encountered coercion variable in a type"
+ | CVTWVR_EVar ct => Error "encountered expression variable in a type abstraction"
+ | CVTWVR_TyVar k => coreTypeToWeakType' t >>= fun t' => OK (WForAllTy (weakTypeVar cv k) t')
+ | CVTWVR_CoVar t1 t2 => coreTypeToWeakTypeCheat' t1 >>= fun t1' =>
+ coreTypeToWeakTypeCheat' t2 >>= fun t2' =>
+ coreTypeToWeakType' t >>= fun t3' =>
+ OK (WCoFunTy t1' t2' t3')
end
| PredTy (ClassP cl lct) => ((fix rec tl := match tl with
| nil => OK nil
| PredTy (EqPred _ _) => Error "hit a bare EqPred"
end.
-Fixpoint coreTypeToWeakType t := addErrorMessage "coreTypeToWeakType" (coreTypeToWeakType' (coreViewDeep t)).
+Definition coreTypeToWeakType t :=
+ addErrorMessage ("during coreTypeToWeakType on " +++ toString t +++ eol) (coreTypeToWeakType' (coreViewDeep t)).
+
+Definition coreVarToWeakVar' (cv:CoreVar) : ???WeakVar :=
+ addErrorMessage ("during coreVarToWeakVar on " +++ toString cv +++ eol)
+ match coreVarToWeakVar cv with
+ | CVTWVR_EVar ct => coreTypeToWeakType ct >>= fun t' => OK (WExprVar (weakExprVar cv t'))
+ | CVTWVR_TyVar k => OK (WTypeVar (weakTypeVar cv k))
+ | CVTWVR_CoVar t1 t2 =>
+ (* this will choke if given a coercion-between-coercions (EqPred (EqPred c1 c2) (EqPred c3 c4)) *)
+ addErrorMessage ("with t2=" +++ toString t2 +++ eol)
+ ((coreTypeToWeakType t2) >>= fun t2' =>
+ addErrorMessage ("with t1=" +++ toString t1 +++ eol)
+ (coreTypeToWeakType t1) >>= fun t1' =>
+ OK (WCoerVar (weakCoerVar cv t1' t2')))
+ end.
+Definition tyConTyVars (tc:CoreTyCon) :=
+ filter (map (fun x => match coreVarToWeakVar' x with OK (WTypeVar v) => Some v | _ => None end) (getTyConTyVars_ tc)).
+ Opaque tyConTyVars.
+Definition tyConKind (tc:TyCon) : list Kind := map (fun (x:WeakTypeVar) => x:Kind) (tyConTyVars tc).
(* detects our crude Core-encoding of modal type introduction/elimination forms *)
Definition isBrak (ce:@CoreExpr CoreVar) : ??(WeakExprVar * WeakTypeVar * CoreType) :=
match ce with
| (CoreEApp (CoreEApp (CoreEVar v) (CoreEType (TyVarTy ec))) (CoreEType tbody))
=> if coreName_eq hetmet_brak_name (coreVarCoreName v) then
- match coreVarToWeakVar ec with
- | WExprVar _ => None
- | WCoerVar _ => None
- | WTypeVar tv => match coreVarToWeakVar v with
- | WExprVar v' => Some (v',tv,tbody)
+ match coreVarToWeakVar' ec with
+ | OK (WTypeVar tv) => match coreVarToWeakVar' v with
+ | OK (WExprVar v') => Some (v',tv,tbody)
| _ => None
end
+ | _ => None
end else None
| _ => None
end.
match ce with
| (CoreEApp (CoreEApp (CoreEVar v) (CoreEType (TyVarTy ec))) (CoreEType tbody))
=> if coreName_eq hetmet_esc_name (coreVarCoreName v) then
- match coreVarToWeakVar ec with
- | WExprVar _ => None
- | WTypeVar tv => match coreVarToWeakVar v with
- | WExprVar v' => Some (v',tv,tbody)
+ match coreVarToWeakVar' ec with
+ | OK (WTypeVar tv) => match coreVarToWeakVar' v with
+ | OK (WExprVar v') => Some (v',tv,tbody)
| _ => None
end
- | WCoerVar _ => None
+ | _ => None
end else None
| _ => None
end.
+Definition isKappa (ce:@CoreExpr CoreVar) : bool :=
+match ce with
+ | (CoreEApp
+ (CoreEApp
+ (CoreEApp
+ (CoreEVar v)
+ (CoreEType t1))
+ (CoreEType t2))
+ (CoreEType t3))
+ => if coreName_eq hetmet_kappa_name (coreVarCoreName v) then true else false
+ | _ => false
+end.
+
+Definition isKappaApp (ce:@CoreExpr CoreVar) : bool :=
+match ce with
+ | (CoreEApp (CoreEApp
+ (CoreEApp
+ (CoreEApp
+ (CoreEVar v)
+ (CoreEType t1))
+ (CoreEType t2))
+ (CoreEType t3)) _)
+ => if coreName_eq hetmet_kappa_app_name (coreVarCoreName v) then true else false
+ | _ => false
+end.
+
Definition isCSP (ce:@CoreExpr CoreVar) : ??(WeakExprVar * WeakTypeVar * CoreType) :=
match ce with
| (CoreEApp (CoreEApp (CoreEVar v) (CoreEType (TyVarTy ec))) (CoreEType tbody))
=> if coreName_eq hetmet_csp_name (coreVarCoreName v) then
- match coreVarToWeakVar ec with
- | WExprVar _ => None
- | WTypeVar tv => match coreVarToWeakVar v with
- | WExprVar v' => Some (v',tv,tbody)
+ match coreVarToWeakVar' ec with
+ | OK (WTypeVar tv) => match coreVarToWeakVar' v with
+ | OK (WExprVar v') => Some (v',tv,tbody)
| _ => None
end
- | WCoerVar _ => None
+ | _ => None
end else None
| _ => None
end.
| _ => Error ("expectTyConApp encountered " +++ toString wt)
end.
+(* expects to see an EType with a coercion payload *)
+Definition coreExprToWeakCoercion t1 t2 (ce:@CoreExpr CoreVar) : ???WeakCoercion :=
+ match ce with
+ | CoreEType t => (*OK (coreCoercionToWeakCoercion t)*) OK (WCoUnsafe t1 t2)
+ | _ => Error ("coreExprToWeakCoercion got a " +++ toString ce)
+ end.
+
+(* expects to see an EType *)
+Definition coreExprToWeakType (ce:@CoreExpr CoreVar) : ???WeakType :=
+ match ce with
+ | CoreEType t => coreTypeToWeakType t
+ | _ => Error ("coreExprToWeakType got a " +++ toString ce)
+ end.
+
Fixpoint coreExprToWeakExpr (ce:@CoreExpr CoreVar) : ???WeakExpr :=
match ce with
| CoreELit lit => OK (WELit lit)
| CoreENote n e => coreExprToWeakExpr e >>= fun e' => OK (WENote n e')
| CoreEType t => Error "encountered CoreEType in a position where an Expr should have been"
+ | CoreECoercion co => Error "encountered CoreECoercion in a position where an Expr should have been"
| CoreECast e co => coreExprToWeakExpr e >>= fun e' =>
- OK (WECast e' (coreCoercionToWeakCoercion co))
+ let (ct1,ct2) := coercionKind co
+ in coreTypeToWeakType ct1 >>= fun t1 =>
+ coreTypeToWeakType ct2 >>= fun t2 =>
+ OK (WECast e' (WCoUnsafe t1 t2))
- | CoreEVar v => match coreVarToWeakVar v with
+ | CoreEVar v => coreVarToWeakVar' v >>= fun v' => match v' with
| WExprVar ev => OK (WEVar ev)
| WTypeVar _ => Error "found a type variable inside an EVar!"
| WCoerVar _ => Error "found a coercion variable inside an EVar!"
coreExprToWeakExpr e2 >>= fun e' =>
coreTypeToWeakType t >>= fun t' =>
OK (WECSP v tv e' t')
- | None => coreExprToWeakExpr e1 >>= fun e1' =>
- match e2 with
- | CoreEType t =>
- coreTypeToWeakType t >>= fun t' =>
- OK (WETyApp e1' t')
- | _ => coreExprToWeakExpr e2
- >>= fun e2' => OK (WEApp e1' e2')
- end
- end
- end
+ | None =>
+ (*
+ if isKappa e1
+ then match e2 with
+ | CoreELam v e => match coreVarToWeakVar' v with
+ | OK (WExprVar ev) =>
+ coreExprToWeakExpr e >>= fun e' =>
+ OK (WEKappa ev e')
+ | _ => Error "bogus"
+ end
+ | _ => Error "bogus"
+ end
+ else if isKappaApp e1
+ then match e1 with
+ | (CoreEApp (CoreEApp (CoreEApp (CoreEApp _ _) _) _) e1') =>
+ coreExprToWeakExpr e1' >>= fun e1'' =>
+ coreExprToWeakExpr e2 >>= fun e2'' =>
+ OK (WEKappaApp e1'' e2'')
+ | _ => Error "bogus"
+ end
+ else
+ *)
+ coreExprToWeakExpr e1 >>= fun e1' =>
+ match e2 with
+ | CoreEType t =>
+ coreTypeToWeakType t >>= fun t' =>
+ OK (WETyApp e1' t')
+ | _ => coreExprToWeakExpr e2
+ >>= fun e2' => OK (WEApp e1' e2')
+ end
+ end
+ end
end
- | CoreELam v e => match coreVarToWeakVar v with
+ | CoreELam v e => coreVarToWeakVar' v >>= fun v' => match v' with
| WExprVar ev => coreExprToWeakExpr e >>= fun e' => OK (WELam ev e')
| WTypeVar tv => coreExprToWeakExpr e >>= fun e' => OK (WETyLam tv e')
| WCoerVar cv => coreExprToWeakExpr e >>= fun e' => OK (WECoLam cv e')
end
- | CoreELet (CoreNonRec v ve) e => match coreVarToWeakVar v with
+ | CoreELet (CoreNonRec v ve) e => coreVarToWeakVar' v >>= fun v' => match v' with
| WExprVar ev => coreExprToWeakExpr ve >>= fun ve' =>
coreExprToWeakExpr e >>= fun e' => OK (WELet ev ve' e')
- | WTypeVar _ => match e with
- | CoreEType t => Error "saw a type-let"
+ | WTypeVar tv => match e with
+ | CoreEType t => coreExprToWeakExpr e >>= fun e' =>
+ coreExprToWeakType ve >>= fun ty' =>
+ OK (WETyApp (WETyLam tv e') ty')
| _ => Error "saw (ELet <tyvar> e) where e!=EType"
end
- | WCoerVar _ => Error "saw an (ELet <coercionVar>)"
+ | WCoerVar (weakCoerVar cv t1 t2) =>
+ coreExprToWeakExpr e >>= fun e' =>
+ coreExprToWeakCoercion t1 t2 ve >>= fun co' =>
+ OK (WECoApp (WECoLam (weakCoerVar cv t1 t2) e') co')
end
| CoreELet (CoreRec rb) e =>
match cel with
| nil => OK nil
| (v',e')::t => coreExprToWeakExprList t >>= fun t' =>
- match coreVarToWeakVar v' with
+ coreVarToWeakVar' v' >>= fun v'' => match v'' with
| WExprVar ev => coreExprToWeakExpr e' >>= fun e' => OK ((ev,e')::t')
| WTypeVar _ => Error "found a type variable in a recursive let"
| WCoerVar _ => Error "found a coercion variable in a recursive let"
OK (WELetRec (unleaves' rb') e')
| CoreECase e v tbranches alts =>
- match coreVarToWeakVar v with
+ coreVarToWeakVar' v >>= fun v' => match v' with
| WTypeVar _ => Error "found a type variable in a case"
| WCoerVar _ => Error "found a coercion variable in a case"
| WExprVar ev =>
match alt with
| DEFAULT => OK ((WeakDEFAULT,nil,nil,nil,e')::rest')
| LitAlt lit => OK ((WeakLitAlt lit,nil,nil,nil,e')::rest')
- | DataAlt dc => let vars := map coreVarToWeakVar vars in
+ | DataAlt dc => let vars := map coreVarToWeakVar' vars in
OK (((WeakDataAlt dc),
- (filter (map (fun x => match x with WTypeVar v => Some v | _ => None end) vars)),
- (filter (map (fun x => match x with WCoerVar v => Some v | _ => None end) vars)),
- (filter (map (fun x => match x with WExprVar v => Some v | _ => None end) vars)),
+ (filter (map (fun x => match x with OK (WTypeVar v) => Some v | _ => None end) vars)),
+ (filter (map (fun x => match x with OK (WCoerVar v) => Some v | _ => None end) vars)),
+ (filter (map (fun x => match x with OK (WExprVar v) => Some v | _ => None end) vars)),
e')::rest')
end
end) alts)
OK (WECase ev scrutinee tbranches' tc lt (unleaves branches))
end
end.
-
-
-
-
Require Import Coq.Lists.List.
Require Import HaskKinds.
Require Import HaskCoreVars.
-Require Import HaskLiteralsAndTyCons.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
+
+Variable CoreCoercionCoAxiom : Type. Extract Inlined Constant CoreCoercionCoAxiom => "Coercion.CoAxiom".
+Variable Int : Type. Extract Inlined Constant Int => "Prelude.Int".
-Variable CoreCoercion : Type. Extract Inlined Constant CoreCoercion => "Coercion.Coercion".
Variable classTyCon : Class_ -> CoreTyCon. Extract Inlined Constant classTyCon => "Class.classTyCon".
Variable coreTyConToString : CoreTyCon -> string. Extract Inlined Constant coreTyConToString => "outputableToString".
Variable coreDataConToString : CoreDataCon -> string. Extract Inlined Constant coreDataConToString => "outputableToString".
Extract Inductive PredType =>
"TypeRep.PredType" [ "TypeRep.ClassP" "TypeRep.IParam" "TypeRep.EqPred" ].
+Inductive CoreCoercion : Type :=
+ CoreCoercionRefl : CoreType -> CoreCoercion
+ | CoreCoercionTyConAppCo : CoreTyCon -> list CoreCoercion -> CoreCoercion
+ | CoreCoercionAppCo : CoreCoercion -> CoreCoercion -> CoreCoercion
+ | CoreCoercionForAllCo : CoreVar -> CoreCoercion -> CoreCoercion
+ | CoreCoercionCoVarCo : CoreVar -> CoreCoercion
+ | CoreCoercionAxiomInstCo : CoreCoercionCoAxiom -> list CoreCoercion -> CoreCoercion
+ | CoreCoercionUnsafeCo : CoreType -> CoreType -> CoreCoercion
+ | CoreCoercionSymCo : CoreCoercion -> CoreCoercion
+ | CoreCoercionTransCo : CoreCoercion -> CoreCoercion -> CoreCoercion
+ | CoreCoercionNthCo : Int -> CoreCoercion -> CoreCoercion
+ | CoreCoercionInstCo : CoreCoercion -> CoreType -> CoreCoercion.
+
+Extract Inductive CoreCoercion =>
+ "Coercion.Coercion" [
+ "Coercion.Refl"
+ "Coercion.TyConAppCo"
+ "Coercion.AppCo"
+ "Coercion.ForAllCo"
+ "Coercion.CoVarCo"
+ "Coercion.AxiomInstCo"
+ "Coercion.UnsafeCo"
+ "Coercion.SymCo"
+ "Coercion.TransCo"
+ "Coercion.NthCo"
+ "Coercion.InstCo" ].
+
Variable coreNameToString : CoreName -> string. Extract Inlined Constant coreNameToString => "outputableToString".
Variable coreCoercionToString : CoreCoercion -> string. Extract Inlined Constant coreCoercionToString => "outputableToString".
-Variable coreCoercionKind : CoreCoercion -> CoreType*CoreType. Extract Inlined Constant coreCoercionKind => "Coercion.coercionKind".
-Variable kindOfCoreType : CoreType -> Kind. Extract Inlined Constant kindOfCoreType => "(coreKindToKind . Coercion.typeKind)".
+Variable coreCoercionKind : Kind -> CoreType*CoreType.
+ Extract Inlined Constant coreCoercionKind => "(Coercion.coercionKind . kindToCoreKind)".
+Variable kindOfCoreType : CoreType -> Kind. Extract Inlined Constant kindOfCoreType => "(coreKindToKind . Kind.typeKind)".
Variable coreTypeToString : CoreType -> string. Extract Inlined Constant coreTypeToString => "(outputableToString . coreViewDeep)".
+Variable setVarType : CoreVar -> CoreType -> CoreVar. Extract Inlined Constant setVarType => "Var.setVarType".
(* GHC provides decision procedures for equality on its primitive types; we tell Coq to blindly trust them *)
Variable coreTyCon_eq : EqDecider CoreTyCon. Extract Inlined Constant coreTyCon_eq => "(==)".
Require Import Preamble.
Require Import General.
Require Import Coq.Strings.String.
-Require Import HaskLiteralsAndTyCons.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
(* GHC uses a single type for expression variables, type variables, and coercion variables; this is that type *)
Variable CoreVar : Type. Extract Inlined Constant CoreVar => "Var.Var".
--- /dev/null
+(*********************************************************************************************************************************)
+(* HaskFlattener: *)
+(* *)
+(* The Flattening Functor. *)
+(* *)
+(*********************************************************************************************************************************)
+
+Generalizable All Variables.
+Require Import Preamble.
+Require Import General.
+Require Import NaturalDeduction.
+Require Import NaturalDeductionContext.
+Require Import Coq.Strings.String.
+Require Import Coq.Lists.List.
+
+Require Import HaskKinds.
+Require Import HaskCoreTypes.
+Require Import HaskCoreVars.
+Require Import HaskWeakTypes.
+Require Import HaskWeakVars.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
+Require Import HaskStrongTypes.
+Require Import HaskProof.
+Require Import NaturalDeduction.
+
+Require Import HaskStrongTypes.
+Require Import HaskStrong.
+Require Import HaskProof.
+Require Import HaskStrongToProof.
+Require Import HaskProofToStrong.
+Require Import HaskWeakToStrong.
+
+Require Import HaskSkolemizer.
+
+Open Scope nd_scope.
+Set Printing Width 130.
+
+(*
+ * The flattening transformation. Currently only TWO-level languages are
+ * supported, and the level-1 sublanguage is rather limited.
+ *
+ * This file abuses terminology pretty badly. For purposes of this file,
+ * "PCF" means "the level-1 sublanguage" and "FC" (aka System FC) means
+ * the whole language (level-0 language including bracketed level-1 terms)
+ *)
+Section HaskFlattener.
+
+ Ltac eqd_dec_refl' :=
+ match goal with
+ | [ |- context[@eqd_dec ?T ?V ?X ?X] ] =>
+ destruct (@eqd_dec T V X X) as [eqd_dec1 | eqd_dec2];
+ [ clear eqd_dec1 | set (eqd_dec2 (refl_equal _)) as eqd_dec2'; inversion eqd_dec2' ]
+ end.
+
+ Definition v2t {Γ}(ec:HaskTyVar Γ ECKind) : HaskType Γ ECKind := fun TV ite => TVar (ec TV ite).
+
+ Definition levelMatch {Γ}(lev:HaskLevel Γ) : LeveledHaskType Γ ★ -> bool :=
+ fun t => match t with ttype@@tlev => if eqd_dec tlev lev then true else false end.
+
+ (* In a tree of types, replace any type at depth "lev" or greater None *)
+ Definition mkDropFlags {Γ}(lev:HaskLevel Γ)(tt:Tree ??(LeveledHaskType Γ ★)) : TreeFlags tt :=
+ mkFlags (liftBoolFunc false (levelMatch lev)) tt.
+
+ Definition drop_lev {Γ}(lev:HaskLevel Γ)(tt:Tree ??(LeveledHaskType Γ ★)) : Tree ??(LeveledHaskType Γ ★) :=
+ dropT (mkDropFlags lev tt).
+
+ (* The opposite: replace any type which is NOT at level "lev" with None *)
+ Definition mkTakeFlags {Γ}(lev:HaskLevel Γ)(tt:Tree ??(LeveledHaskType Γ ★)) : TreeFlags tt :=
+ mkFlags (liftBoolFunc true (bnot ○ levelMatch lev)) tt.
+
+ Definition take_lev {Γ}(lev:HaskLevel Γ)(tt:Tree ??(LeveledHaskType Γ ★)) : Tree ??(LeveledHaskType Γ ★) :=
+ dropT (mkTakeFlags lev tt).
+(*
+ mapOptionTree (fun x => flatten_type (unlev x))
+ (maybeTree (takeT tt (mkFlags (
+ fun t => match t with
+ | Some (ttype @@ tlev) => if eqd_dec tlev lev then true else false
+ | _ => true
+ end
+ ) tt))).
+
+ Definition maybeTree {T}(t:??(Tree ??T)) : Tree ??T :=
+ match t with
+ | None => []
+ | Some x => x
+ end.
+*)
+
+ Lemma drop_lev_lemma : forall Γ (lev:HaskLevel Γ) x, drop_lev lev [x @@ lev] = [].
+ intros; simpl.
+ Opaque eqd_dec.
+ unfold drop_lev.
+ simpl.
+ unfold mkDropFlags.
+ simpl.
+ Transparent eqd_dec.
+ eqd_dec_refl'.
+ auto.
+ Qed.
+
+ Lemma drop_lev_lemma_s : forall Γ (lev:HaskLevel Γ) ec x, drop_lev (ec::lev) [x @@ (ec :: lev)] = [].
+ intros; simpl.
+ Opaque eqd_dec.
+ unfold drop_lev.
+ unfold mkDropFlags.
+ simpl.
+ Transparent eqd_dec.
+ eqd_dec_refl'.
+ auto.
+ Qed.
+
+ Lemma take_lemma : forall Γ (lev:HaskLevel Γ) x, take_lev lev [x @@ lev] = [x @@ lev].
+ intros; simpl.
+ Opaque eqd_dec.
+ unfold take_lev.
+ unfold mkTakeFlags.
+ simpl.
+ Transparent eqd_dec.
+ eqd_dec_refl'.
+ auto.
+ Qed.
+
+ Lemma take_lemma' : forall Γ (lev:HaskLevel Γ) x, take_lev lev (x @@@ lev) = x @@@ lev.
+ intros.
+ induction x.
+ destruct a; simpl; try reflexivity.
+ apply take_lemma.
+ simpl.
+ rewrite <- IHx1 at 2.
+ rewrite <- IHx2 at 2.
+ reflexivity.
+ Qed.
+
+ Ltac drop_simplify :=
+ match goal with
+ | [ |- context[@drop_lev ?G ?L [ ?X @@ ?L ] ] ] =>
+ rewrite (drop_lev_lemma G L X)
+ | [ |- context[@drop_lev ?G (?E :: ?L) [ ?X @@ (?E :: ?L) ] ] ] =>
+ rewrite (drop_lev_lemma_s G L E X)
+ | [ |- context[@drop_lev ?G ?N (?A,,?B)] ] =>
+ change (@drop_lev G N (A,,B)) with ((@drop_lev G N A),,(@drop_lev G N B))
+ | [ |- context[@drop_lev ?G ?N (T_Leaf None)] ] =>
+ change (@drop_lev G N (T_Leaf (@None (LeveledHaskType G ★)))) with (T_Leaf (@None (LeveledHaskType G ★)))
+ end.
+
+ Ltac take_simplify :=
+ match goal with
+ | [ |- context[@take_lev ?G ?L [ ?X @@ ?L ] ] ] =>
+ rewrite (take_lemma G L X)
+ | [ |- context[@take_lev ?G ?L [ ?X @@@ ?L ] ] ] =>
+ rewrite (take_lemma' G L X)
+ | [ |- context[@take_lev ?G ?N (?A,,?B)] ] =>
+ change (@take_lev G N (A,,B)) with ((@take_lev G N A),,(@take_lev G N B))
+ | [ |- context[@take_lev ?G ?N (T_Leaf None)] ] =>
+ change (@take_lev G N (T_Leaf (@None (LeveledHaskType G ★)))) with (T_Leaf (@None (LeveledHaskType G ★)))
+ end.
+
+
+ (*******************************************************************************)
+
+
+ Context {unitTy : forall TV, RawHaskType TV ECKind -> RawHaskType TV ★ }.
+ Context {prodTy : forall TV, RawHaskType TV ECKind -> RawHaskType TV ★ -> RawHaskType TV ★ -> RawHaskType TV ★ }.
+ Context {gaTy : forall TV, RawHaskType TV ECKind -> RawHaskType TV ★ -> RawHaskType TV ★ -> RawHaskType TV ★ }.
+
+ Definition ga_mk_tree' {TV}(ec:RawHaskType TV ECKind)(tr:Tree ??(RawHaskType TV ★)) : RawHaskType TV ★ :=
+ reduceTree (unitTy TV ec) (prodTy TV ec) tr.
+
+ Definition ga_mk_tree {Γ}(ec:HaskType Γ ECKind)(tr:Tree ??(HaskType Γ ★)) : HaskType Γ ★ :=
+ fun TV ite => ga_mk_tree' (ec TV ite) (mapOptionTree (fun x => x TV ite) tr).
+
+ Definition ga_mk_raw {TV}(ec:RawHaskType TV ECKind)(ant suc:Tree ??(RawHaskType TV ★)) : RawHaskType TV ★ :=
+ gaTy TV ec
+ (ga_mk_tree' ec ant)
+ (ga_mk_tree' ec suc).
+
+ Definition ga_mk {Γ}(ec:HaskType Γ ECKind)(ant suc:Tree ??(HaskType Γ ★)) : HaskType Γ ★ :=
+ fun TV ite => gaTy TV (ec TV ite) (ga_mk_tree ec ant TV ite) (ga_mk_tree ec suc TV ite).
+
+ (*
+ * The story:
+ * - code types <[t]>@c become garrows c () t
+ * - free variables of type t at a level lev deeper than the succedent become garrows c () t
+ * - free variables at the level of the succedent become
+ *)
+ Fixpoint flatten_rawtype {TV}{κ}(exp: RawHaskType TV κ) : RawHaskType TV κ :=
+ match exp with
+ | TVar _ x => TVar x
+ | TAll _ y => TAll _ (fun v => flatten_rawtype (y v))
+ | TApp _ _ x y => TApp (flatten_rawtype x) (flatten_rawtype y)
+ | TCon tc => TCon tc
+ | TCoerc _ t1 t2 t => TCoerc (flatten_rawtype t1) (flatten_rawtype t2) (flatten_rawtype t)
+ | TArrow => TArrow
+ | TCode ec e => let e' := flatten_rawtype e
+ in ga_mk_raw ec (unleaves_ (take_arg_types e')) [drop_arg_types e']
+ | TyFunApp tfc kl k lt => TyFunApp tfc kl k (flatten_rawtype_list _ lt)
+ end
+ with flatten_rawtype_list {TV}(lk:list Kind)(exp:@RawHaskTypeList TV lk) : @RawHaskTypeList TV lk :=
+ match exp in @RawHaskTypeList _ LK return @RawHaskTypeList TV LK with
+ | TyFunApp_nil => TyFunApp_nil
+ | TyFunApp_cons κ kl t rest => TyFunApp_cons _ _ (flatten_rawtype t) (flatten_rawtype_list _ rest)
+ end.
+
+ Definition flatten_type {Γ}{κ}(ht:HaskType Γ κ) : HaskType Γ κ :=
+ fun TV ite => flatten_rawtype (ht TV ite).
+
+ Fixpoint levels_to_tcode {Γ}(ht:HaskType Γ ★)(lev:HaskLevel Γ) : HaskType Γ ★ :=
+ match lev with
+ | nil => flatten_type ht
+ | ec::lev' => @ga_mk _ (v2t ec) [] [levels_to_tcode ht lev']
+ end.
+
+ Definition flatten_leveled_type {Γ}(ht:LeveledHaskType Γ ★) : LeveledHaskType Γ ★ :=
+ levels_to_tcode (unlev ht) (getlev ht) @@ nil.
+
+ (* AXIOMS *)
+
+ Axiom literal_types_unchanged : forall Γ l, flatten_type (literalType l) = literalType(Γ:=Γ) l.
+
+ Axiom flatten_coercion : forall Γ Δ κ (σ τ:HaskType Γ κ) (γ:HaskCoercion Γ Δ (σ ∼∼∼ τ)),
+ HaskCoercion Γ Δ (flatten_type σ ∼∼∼ flatten_type τ).
+
+ Axiom flatten_commutes_with_substT :
+ forall κ Γ (Δ:CoercionEnv Γ) (σ:∀ TV, InstantiatedTypeEnv TV Γ → TV κ → RawHaskType TV ★) (τ:HaskType Γ κ),
+ flatten_type (substT σ τ) = substT (fun TV ite v => flatten_rawtype (σ TV ite v))
+ (flatten_type τ).
+
+ Axiom flatten_commutes_with_HaskTAll :
+ forall κ Γ (Δ:CoercionEnv Γ) (σ:∀ TV, InstantiatedTypeEnv TV Γ → TV κ → RawHaskType TV ★),
+ flatten_type (HaskTAll κ σ) = HaskTAll κ (fun TV ite v => flatten_rawtype (σ TV ite v)).
+
+ Axiom flatten_commutes_with_HaskTApp :
+ forall n κ Γ (Δ:CoercionEnv Γ) (σ:∀ TV, InstantiatedTypeEnv TV Γ → TV κ → RawHaskType TV ★),
+ flatten_type (HaskTApp (weakF_ σ) (FreshHaskTyVar_ κ)) =
+ HaskTApp (weakF_ (fun TV ite v => flatten_rawtype (σ TV ite v))) (FreshHaskTyVar_(n:=n) κ).
+
+ Axiom flatten_commutes_with_weakLT : forall n (Γ:TypeEnv) κ t,
+ flatten_leveled_type (weakLT_(n:=n)(Γ:=Γ)(κ:=κ) t) = weakLT_(n:=n)(Γ:=Γ)(κ:=κ) (flatten_leveled_type t).
+
+ Axiom globals_do_not_have_code_types : forall (Γ:TypeEnv) (g:Global Γ) v,
+ flatten_type (g v) = g v.
+
+ (* "n" is the maximum depth remaining AFTER flattening *)
+ Definition flatten_judgment (j:Judg) :=
+ match j as J return Judg with
+ | Γ > Δ > ant |- suc @ nil => Γ > Δ > mapOptionTree flatten_leveled_type ant
+ |- mapOptionTree flatten_type suc @ nil
+ | Γ > Δ > ant |- suc @ (ec::lev') => Γ > Δ > mapOptionTree flatten_leveled_type (drop_lev (ec::lev') ant)
+ |- [ga_mk (v2t ec)
+ (mapOptionTree (flatten_type ○ unlev) (take_lev (ec::lev') ant))
+ (mapOptionTree flatten_type suc )
+ ] @ nil
+ end.
+
+ Class garrow :=
+ { ga_id : ∀ Γ Δ ec l a , ND Rule [] [Γ > Δ > [] |- [@ga_mk Γ ec a a ]@l ]
+ ; ga_cancelr : ∀ Γ Δ ec l a , ND Rule [] [Γ > Δ > [] |- [@ga_mk Γ ec (a,,[]) a ]@l ]
+ ; ga_cancell : ∀ Γ Δ ec l a , ND Rule [] [Γ > Δ > [] |- [@ga_mk Γ ec ([],,a) a ]@l ]
+ ; ga_uncancelr : ∀ Γ Δ ec l a , ND Rule [] [Γ > Δ > [] |- [@ga_mk Γ ec a (a,,[]) ]@l ]
+ ; ga_uncancell : ∀ Γ Δ ec l a , ND Rule [] [Γ > Δ > [] |- [@ga_mk Γ ec a ([],,a) ]@l ]
+ ; ga_assoc : ∀ Γ Δ ec l a b c, ND Rule [] [Γ > Δ > [] |- [@ga_mk Γ ec ((a,,b),,c) (a,,(b,,c)) ]@l ]
+ ; ga_unassoc : ∀ Γ Δ ec l a b c, ND Rule [] [Γ > Δ > [] |- [@ga_mk Γ ec (a,,(b,,c)) ((a,,b),,c) ]@l ]
+ ; ga_swap : ∀ Γ Δ ec l a b , ND Rule [] [Γ > Δ > [] |- [@ga_mk Γ ec (a,,b) (b,,a) ]@l ]
+ ; ga_drop : ∀ Γ Δ ec l a , ND Rule [] [Γ > Δ > [] |- [@ga_mk Γ ec a [] ]@l ]
+ ; ga_copy : ∀ Γ Δ ec l a , ND Rule [] [Γ > Δ > [] |- [@ga_mk Γ ec a (a,,a) ]@l ]
+ ; ga_first : ∀ Γ Δ ec l a b x, ND Rule [] [Γ > Δ > [@ga_mk Γ ec a b @@l] |- [@ga_mk Γ ec (a,,x) (b,,x) ]@l ]
+ ; ga_second : ∀ Γ Δ ec l a b x, ND Rule [] [Γ > Δ > [@ga_mk Γ ec a b @@l] |- [@ga_mk Γ ec (x,,a) (x,,b) ]@l ]
+ ; ga_lit : ∀ Γ Δ ec l lit , ND Rule [] [Γ > Δ > [] |- [@ga_mk Γ ec [] [literalType lit] ]@l ]
+ ; ga_curry : ∀ Γ Δ ec l a b c, ND Rule [] [Γ > Δ > [@ga_mk Γ ec (a,,[b]) [c] @@ l] |- [@ga_mk Γ ec a [b ---> c] ]@ l ]
+ ; ga_loopl : ∀ Γ Δ ec l x y z, ND Rule [] [Γ > Δ > [@ga_mk Γ ec (z,,x) (z,,y) @@ l] |- [@ga_mk Γ ec x y ]@ l ]
+ ; ga_loopr : ∀ Γ Δ ec l x y z, ND Rule [] [Γ > Δ > [@ga_mk Γ ec (x,,z) (y,,z) @@ l] |- [@ga_mk Γ ec x y ]@ l ]
+ ; ga_comp : ∀ Γ Δ ec l a b c, ND Rule [] [Γ > Δ > [@ga_mk Γ ec a b @@ l],,[@ga_mk Γ ec b c @@ l] |- [@ga_mk Γ ec a c ]@l ]
+ ; ga_apply : ∀ Γ Δ ec l a a' b c,
+ ND Rule [] [Γ > Δ > [@ga_mk Γ ec a [b ---> c] @@ l],,[@ga_mk Γ ec a' [b] @@ l] |- [@ga_mk Γ ec (a,,a') [c] ]@l ]
+ ; ga_kappa : ∀ Γ Δ ec l a b c Σ, ND Rule
+ [Γ > Δ > Σ,,[@ga_mk Γ ec [] a @@ l] |- [@ga_mk Γ ec b c ]@l ]
+ [Γ > Δ > Σ |- [@ga_mk Γ ec (a,,b) c ]@l ]
+ }.
+ Context `(gar:garrow).
+
+ Notation "a ~~~~> b" := (@ga_mk _ _ a b) (at level 20).
+
+ Definition boost : forall Γ Δ ant x y {lev},
+ ND Rule [] [ Γ > Δ > [x@@lev] |- [y]@lev ] ->
+ ND Rule [ Γ > Δ > ant |- [x]@lev ] [ Γ > Δ > ant |- [y]@lev ].
+ intros.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply ACanR ].
+ eapply nd_comp; [ idtac | apply RLet ].
+ eapply nd_comp; [ apply nd_rlecnac | idtac ].
+ apply nd_prod.
+ apply nd_id.
+ eapply nd_comp.
+ apply X.
+ eapply nd_rule.
+ eapply RArrange.
+ apply AuCanR.
+ Defined.
+
+ Definition precompose Γ Δ ec : forall a x y z lev,
+ ND Rule
+ [ Γ > Δ > a |- [@ga_mk _ ec y z ]@lev ]
+ [ Γ > Δ > a,,[@ga_mk _ ec x y @@ lev] |- [@ga_mk _ ec x z ]@lev ].
+ intros.
+ eapply nd_comp; [ idtac | eapply RLet ].
+ eapply nd_comp; [ apply nd_rlecnac | idtac ].
+ apply nd_prod.
+ apply nd_id.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AExch ].
+ apply ga_comp.
+ Defined.
+
+ Definition precompose' Γ Δ ec : forall a b x y z lev,
+ ND Rule
+ [ Γ > Δ > a,,b |- [@ga_mk _ ec y z ]@lev ]
+ [ Γ > Δ > a,,([@ga_mk _ ec x y @@ lev],,b) |- [@ga_mk _ ec x z ]@lev ].
+ intros.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply ALeft; eapply AExch ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AuAssoc ].
+ apply precompose.
+ Defined.
+
+ Definition postcompose_ Γ Δ ec : forall a x y z lev,
+ ND Rule
+ [ Γ > Δ > a |- [@ga_mk _ ec x y ]@lev ]
+ [ Γ > Δ > a,,[@ga_mk _ ec y z @@ lev] |- [@ga_mk _ ec x z ]@lev ].
+ intros.
+ eapply nd_comp; [ idtac | eapply RLet ].
+ eapply nd_comp; [ apply nd_rlecnac | idtac ].
+ apply nd_prod.
+ apply nd_id.
+ apply ga_comp.
+ Defined.
+
+ Definition postcompose Γ Δ ec : forall x y z lev,
+ ND Rule [] [ Γ > Δ > [] |- [@ga_mk _ ec x y ]@lev ] ->
+ ND Rule [] [ Γ > Δ > [@ga_mk _ ec y z @@ lev] |- [@ga_mk _ ec x z ]@lev ].
+ intros.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply ACanL ].
+ eapply nd_comp; [ idtac | eapply postcompose_ ].
+ apply X.
+ Defined.
+
+ Definition first_nd : ∀ Γ Δ ec lev a b c Σ,
+ ND Rule [ Γ > Δ > Σ |- [@ga_mk Γ ec a b ]@lev ]
+ [ Γ > Δ > Σ |- [@ga_mk Γ ec (a,,c) (b,,c) ]@lev ].
+ intros.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply ACanR ].
+ eapply nd_comp; [ idtac | apply RLet ].
+ eapply nd_comp; [ apply nd_rlecnac | idtac ].
+ apply nd_prod.
+ apply nd_id.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AuCanR ].
+ apply ga_first.
+ Defined.
+
+ Definition firstify : ∀ Γ Δ ec lev a b c Σ,
+ ND Rule [] [ Γ > Δ > Σ |- [@ga_mk Γ ec a b ]@lev ] ->
+ ND Rule [] [ Γ > Δ > Σ |- [@ga_mk Γ ec (a,,c) (b,,c) ]@lev ].
+ intros.
+ eapply nd_comp.
+ apply X.
+ apply first_nd.
+ Defined.
+
+ Definition second_nd : ∀ Γ Δ ec lev a b c Σ,
+ ND Rule
+ [ Γ > Δ > Σ |- [@ga_mk Γ ec a b ]@lev ]
+ [ Γ > Δ > Σ |- [@ga_mk Γ ec (c,,a) (c,,b) ]@lev ].
+ intros.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply ACanR ].
+ eapply nd_comp; [ idtac | apply RLet ].
+ eapply nd_comp; [ apply nd_rlecnac | idtac ].
+ apply nd_prod.
+ apply nd_id.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AuCanR ].
+ apply ga_second.
+ Defined.
+
+ Definition secondify : ∀ Γ Δ ec lev a b c Σ,
+ ND Rule [] [ Γ > Δ > Σ |- [@ga_mk Γ ec a b ]@lev ] ->
+ ND Rule [] [ Γ > Δ > Σ |- [@ga_mk Γ ec (c,,a) (c,,b) ]@lev ].
+ intros.
+ eapply nd_comp.
+ apply X.
+ apply second_nd.
+ Defined.
+
+ Lemma ga_unkappa : ∀ Γ Δ ec l a b Σ x,
+ ND Rule
+ [Γ > Δ > Σ |- [@ga_mk Γ ec (a,,x) b ]@l ]
+ [Γ > Δ > Σ,,[@ga_mk Γ ec [] a @@ l] |- [@ga_mk Γ ec x b ]@l ].
+ intros.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AExch ].
+ eapply nd_comp; [ idtac | eapply RLet ].
+ eapply nd_comp; [ apply nd_llecnac | idtac ].
+ apply nd_prod.
+ apply ga_first.
+
+ eapply nd_comp; [ idtac | eapply RLet ].
+ eapply nd_comp; [ apply nd_llecnac | idtac ].
+ apply nd_prod.
+ apply postcompose.
+ apply ga_uncancell.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AExch ].
+ apply precompose.
+ Defined.
+
+
+
+
+ (* useful for cutting down on the pretty-printed noise
+
+ Notation "` x" := (take_lev _ x) (at level 20).
+ Notation "`` x" := (mapOptionTree unlev x) (at level 20).
+ Notation "``` x" := (drop_lev _ x) (at level 20).
+ *)
+ Definition flatten_arrangement' :
+ forall Γ (Δ:CoercionEnv Γ)
+ (ec:HaskTyVar Γ ECKind) (lev:HaskLevel Γ) (ant1 ant2:Tree ??(LeveledHaskType Γ ★)) (r:Arrange ant1 ant2),
+ ND Rule [] [Γ > Δ > [] |- [@ga_mk _ (v2t ec) (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) ant2))
+ (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) ant1)) ]@nil ].
+
+ intros Γ Δ ec lev.
+ refine (fix flatten ant1 ant2 (r:Arrange ant1 ant2):
+ ND Rule [] [Γ > Δ > [] |- [@ga_mk _ (v2t ec)
+ (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) ant2))
+ (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) ant1)) ]@nil] :=
+ match r as R in Arrange A B return
+ ND Rule [] [Γ > Δ > [] |- [@ga_mk _ (v2t ec)
+ (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) B))
+ (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) A)) ]@nil]
+ with
+ | AId a => let case_AId := tt in ga_id _ _ _ _ _
+ | ACanL a => let case_ACanL := tt in ga_uncancell _ _ _ _ _
+ | ACanR a => let case_ACanR := tt in ga_uncancelr _ _ _ _ _
+ | AuCanL a => let case_AuCanL := tt in ga_cancell _ _ _ _ _
+ | AuCanR a => let case_AuCanR := tt in ga_cancelr _ _ _ _ _
+ | AAssoc a b c => let case_AAssoc := tt in ga_assoc _ _ _ _ _ _ _
+ | AuAssoc a b c => let case_AuAssoc := tt in ga_unassoc _ _ _ _ _ _ _
+ | AExch a b => let case_AExch := tt in ga_swap _ _ _ _ _ _
+ | AWeak a => let case_AWeak := tt in ga_drop _ _ _ _ _
+ | ACont a => let case_ACont := tt in ga_copy _ _ _ _ _
+ | ALeft a b c r' => let case_ALeft := tt in flatten _ _ r' ;; boost _ _ _ _ _ (ga_second _ _ _ _ _ _ _)
+ | ARight a b c r' => let case_ARight := tt in flatten _ _ r' ;; boost _ _ _ _ _ (ga_first _ _ _ _ _ _ _)
+ | AComp c b a r1 r2 => let case_AComp := tt in (fun r1' r2' => _) (flatten _ _ r1) (flatten _ _ r2)
+ end); clear flatten; repeat take_simplify; repeat drop_simplify; intros.
+
+ destruct case_AComp.
+ set (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) a)) as a' in *.
+ set (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) b)) as b' in *.
+ set (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) c)) as c' in *.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; apply ACanL ].
+ eapply nd_comp; [ idtac | apply
+ (@RLet Γ Δ [] [] (@ga_mk _ (v2t ec) a' b') (@ga_mk _ (v2t ec) a' c')) ].
+ eapply nd_comp; [ apply nd_llecnac | idtac ].
+ apply nd_prod.
+ apply r2'.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; apply AuCanR ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; apply ACanL ].
+ eapply nd_comp; [ idtac | apply RLet ].
+ eapply nd_comp; [ apply nd_llecnac | idtac ].
+ eapply nd_prod.
+ apply r1'.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AExch ].
+ apply ga_comp.
+ Defined.
+
+ Definition flatten_arrangement :
+ forall Γ (Δ:CoercionEnv Γ) n
+ (ec:HaskTyVar Γ ECKind) (lev:HaskLevel Γ) (ant1 ant2:Tree ??(LeveledHaskType Γ ★)) (r:Arrange ant1 ant2) succ,
+ ND Rule
+ [Γ > Δ > mapOptionTree (flatten_leveled_type ) (drop_lev n ant1)
+ |- [@ga_mk _ (v2t ec)
+ (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) ant1))
+ (mapOptionTree (flatten_type ) succ) ]@nil]
+ [Γ > Δ > mapOptionTree (flatten_leveled_type ) (drop_lev n ant2)
+ |- [@ga_mk _ (v2t ec)
+ (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) ant2))
+ (mapOptionTree (flatten_type ) succ) ]@nil].
+ intros.
+ refine ( _ ;; (boost _ _ _ _ _ (postcompose _ _ _ _ _ _ _ (flatten_arrangement' Γ Δ ec lev ant1 ant2 r)))).
+ apply nd_rule.
+ apply RArrange.
+ refine ((fix flatten ant1 ant2 (r:Arrange ant1 ant2) :=
+ match r as R in Arrange A B return
+ Arrange (mapOptionTree (flatten_leveled_type ) (drop_lev _ A))
+ (mapOptionTree (flatten_leveled_type ) (drop_lev _ B)) with
+ | AId a => let case_AId := tt in AId _
+ | ACanL a => let case_ACanL := tt in ACanL _
+ | ACanR a => let case_ACanR := tt in ACanR _
+ | AuCanL a => let case_AuCanL := tt in AuCanL _
+ | AuCanR a => let case_AuCanR := tt in AuCanR _
+ | AAssoc a b c => let case_AAssoc := tt in AAssoc _ _ _
+ | AuAssoc a b c => let case_AuAssoc := tt in AuAssoc _ _ _
+ | AExch a b => let case_AExch := tt in AExch _ _
+ | AWeak a => let case_AWeak := tt in AWeak _
+ | ACont a => let case_ACont := tt in ACont _
+ | ALeft a b c r' => let case_ALeft := tt in ALeft _ (flatten _ _ r')
+ | ARight a b c r' => let case_ARight := tt in ARight _ (flatten _ _ r')
+ | AComp a b c r1 r2 => let case_AComp := tt in AComp (flatten _ _ r1) (flatten _ _ r2)
+ end) ant1 ant2 r); clear flatten; repeat take_simplify; repeat drop_simplify; intros.
+ Defined.
+
+ Definition flatten_arrangement'' :
+ forall Γ Δ ant1 ant2 succ l (r:Arrange ant1 ant2),
+ ND Rule (mapOptionTree (flatten_judgment ) [Γ > Δ > ant1 |- succ @ l])
+ (mapOptionTree (flatten_judgment ) [Γ > Δ > ant2 |- succ @ l]).
+ intros.
+ simpl.
+ destruct l.
+ apply nd_rule.
+ apply RArrange.
+ induction r; simpl.
+ apply AId.
+ apply ACanL.
+ apply ACanR.
+ apply AuCanL.
+ apply AuCanR.
+ apply AAssoc.
+ apply AuAssoc.
+ apply AExch. (* TO DO: check for all-leaf trees here *)
+ apply AWeak.
+ apply ACont.
+ apply ALeft; auto.
+ apply ARight; auto.
+ eapply AComp; [ apply IHr1 | apply IHr2 ].
+
+ apply flatten_arrangement.
+ apply r.
+ Defined.
+
+ Definition ga_join Γ Δ Σ₁ Σ₂ a b ec :
+ ND Rule [] [Γ > Δ > Σ₁ |- [@ga_mk _ ec [] a ]@nil] ->
+ ND Rule [] [Γ > Δ > Σ₂ |- [@ga_mk _ ec [] b ]@nil] ->
+ ND Rule [] [Γ > Δ > Σ₁,,Σ₂ |- [@ga_mk _ ec [] (a,,b) ]@nil].
+ intro pfa.
+ intro pfb.
+ apply secondify with (c:=a) in pfb.
+ apply firstify with (c:=[]) in pfa.
+ eapply nd_comp; [ idtac | eapply RLet ].
+ eapply nd_comp; [ eapply nd_llecnac | idtac ].
+ apply nd_prod.
+ apply pfa.
+ clear pfa.
+
+ eapply nd_comp; [ idtac | eapply RLet ].
+ eapply nd_comp; [ apply nd_llecnac | idtac ].
+ apply nd_prod.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply ACanL ].
+ eapply nd_comp; [ idtac | eapply postcompose_ ].
+ apply ga_uncancelr.
+
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AExch ].
+ eapply nd_comp; [ idtac | eapply precompose ].
+ apply pfb.
+ Defined.
+
+ Definition arrange_brak : forall Γ Δ ec succ t,
+ ND Rule
+ [Γ > Δ >
+ [(@ga_mk _ (v2t ec) [] (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: nil) succ))) @@ nil],,
+ mapOptionTree (flatten_leveled_type ) (drop_lev (ec :: nil) succ) |- [t]@nil]
+ [Γ > Δ > mapOptionTree (flatten_leveled_type ) succ |- [t]@nil].
+
+ intros.
+ unfold drop_lev.
+ set (@arrangeUnPartition _ succ (levelMatch (ec::nil))) as q.
+ set (arrangeMap _ _ flatten_leveled_type q) as y.
+ eapply nd_comp.
+ Focus 2.
+ eapply nd_rule.
+ eapply RArrange.
+ apply y.
+ idtac.
+ clear y q.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AExch ].
+ simpl.
+ eapply nd_comp; [ apply nd_llecnac | idtac ].
+ eapply nd_comp; [ idtac | eapply RLet ].
+ apply nd_prod.
+ Focus 2.
+ apply nd_id.
+ idtac.
+ induction succ; try destruct a; simpl.
+ unfold take_lev.
+ unfold mkTakeFlags.
+ unfold mkFlags.
+ unfold bnot.
+ simpl.
+ destruct l as [t' lev'].
+ destruct lev' as [|ec' lev'].
+ simpl.
+ apply ga_id.
+ unfold levelMatch.
+ set (@eqd_dec (HaskLevel Γ) (haskLevelEqDecidable Γ) (ec' :: lev') (ec :: nil)) as q.
+ destruct q.
+ inversion e; subst.
+ simpl.
+ apply nd_rule.
+ unfold flatten_leveled_type.
+ simpl.
+ unfold flatten_type.
+ simpl.
+ unfold ga_mk.
+ simpl.
+ apply RVar.
+ simpl.
+ apply ga_id.
+ apply ga_id.
+ unfold take_lev.
+ simpl.
+ apply ga_join.
+ apply IHsucc1.
+ apply IHsucc2.
+ Defined.
+
+ Definition arrange_esc : forall Γ Δ ec succ t,
+ ND Rule
+ [Γ > Δ > mapOptionTree (flatten_leveled_type ) succ |- [t]@nil]
+ [Γ > Δ >
+ [(@ga_mk _ (v2t ec) [] (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: nil) succ))) @@ nil],,
+ mapOptionTree (flatten_leveled_type ) (drop_lev (ec :: nil) succ) |- [t]@nil].
+ intros.
+ set (@arrangePartition _ succ (levelMatch (ec::nil))) as q.
+ set (@drop_lev Γ (ec::nil) succ) as q'.
+ assert (@drop_lev Γ (ec::nil) succ=q') as H.
+ reflexivity.
+ unfold drop_lev in H.
+ unfold mkDropFlags in H.
+ rewrite H in q.
+ clear H.
+ set (arrangeMap _ _ flatten_leveled_type q) as y.
+ eapply nd_comp.
+ eapply nd_rule.
+ eapply RArrange.
+ apply y.
+ clear y q.
+
+ set (mapOptionTree flatten_leveled_type (dropT (mkFlags (liftBoolFunc false (bnot ○ levelMatch (ec :: nil))) succ))) as q.
+ destruct (decide_tree_empty q).
+
+ destruct s.
+ simpl.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; apply AExch ].
+ set (fun z z' => @RLet Γ Δ z (mapOptionTree flatten_leveled_type q') t z' nil) as q''.
+ eapply nd_comp; [ idtac | apply RLet ].
+ clear q''.
+ eapply nd_comp; [ apply nd_rlecnac | idtac ].
+ apply nd_prod.
+ apply nd_rule.
+ apply RArrange.
+ eapply AComp; [ idtac | apply ACanR ].
+ apply ALeft.
+ apply (@arrangeCancelEmptyTree _ _ _ _ e).
+
+ eapply nd_comp.
+ eapply nd_rule.
+ eapply (@RVar Γ Δ t nil).
+ apply nd_rule.
+ apply RArrange.
+ eapply AComp.
+ apply AuCanR.
+ apply ALeft.
+ apply AWeak.
+
+ simpl.
+ clear q.
+ unfold q'.
+ clear q'.
+ apply nd_rule.
+ apply RArrange.
+ induction succ.
+ destruct a.
+ destruct l as [t' l'].
+ simpl.
+ Transparent drop_lev.
+ simpl.
+ unfold take_lev.
+ unfold mkTakeFlags.
+ simpl.
+ unfold drop_lev.
+ simpl.
+ unfold mkDropFlags.
+ simpl.
+ unfold flatten_leveled_type.
+ destruct (General.list_eq_dec l' (ec :: nil)); simpl.
+ rewrite e.
+ unfold levels_to_tcode.
+ eapply AComp.
+ apply ACanL.
+ apply AuCanR.
+ eapply AComp.
+ apply ACanR.
+ eapply AComp.
+ apply AuCanL.
+ apply ARight.
+ apply AWeak.
+
+ simpl.
+ apply ARight.
+ apply AWeak.
+
+ drop_simplify.
+ simpl.
+ set (mapOptionTree flatten_leveled_type (drop_lev (ec :: nil) succ2)) as d2 in *.
+ set (mapOptionTree flatten_leveled_type (drop_lev (ec :: nil) succ1)) as d1 in *.
+ set (mapOptionTree flatten_leveled_type (dropT (mkFlags
+ (liftBoolFunc false (bnot ○ levelMatch (ec :: nil))) succ1))) as s1 in *.
+ set (mapOptionTree flatten_leveled_type (dropT (mkFlags
+ (liftBoolFunc false (bnot ○ levelMatch (ec :: nil))) succ2))) as s2 in *.
+ set (mapOptionTree (flatten_type ○ unlev) (dropT (mkFlags
+ (liftBoolFunc true (bnot ○ levelMatch (ec :: nil))) succ1))) as s1' in *.
+ set (mapOptionTree (flatten_type ○ unlev) (dropT (mkFlags
+ (liftBoolFunc true (bnot ○ levelMatch (ec :: nil))) succ2))) as s2' in *.
+
+ eapply AComp.
+ apply arrangeSwapMiddle.
+
+ eapply AComp.
+ eapply ALeft.
+ apply IHsucc2.
+
+ eapply AComp.
+ eapply ARight.
+ apply IHsucc1.
+
+ eapply AComp.
+ apply arrangeSwapMiddle.
+ apply ARight.
+ unfold take_lev.
+ unfold mkTakeFlags.
+
+ unfold s1'.
+ unfold s2'.
+ clear s1' s2'.
+ set (mapOptionTree (flatten_type ○ unlev) (dropT (mkFlags
+ (liftBoolFunc true (bnot ○ levelMatch (ec :: nil))) succ1))) as s1' in *.
+ set (mapOptionTree (flatten_type ○ unlev) (dropT (mkFlags
+ (liftBoolFunc true (bnot ○ levelMatch (ec :: nil))) succ2))) as s2' in *.
+
+ apply (Prelude_error "almost there!").
+ Defined.
+
+ Lemma unlev_relev : forall {Γ}(t:Tree ??(HaskType Γ ★)) lev, mapOptionTree unlev (t @@@ lev) = t.
+ intros.
+ induction t.
+ destruct a; reflexivity.
+ rewrite <- IHt1 at 2.
+ rewrite <- IHt2 at 2.
+ reflexivity.
+ Qed.
+
+ Lemma tree_of_nothing : forall Γ ec t,
+ Arrange (mapOptionTree flatten_leveled_type (drop_lev(Γ:=Γ) (ec :: nil) (t @@@ (ec :: nil)))) [].
+ intros.
+ induction t; try destruct o; try destruct a.
+ simpl.
+ drop_simplify.
+ simpl.
+ apply AId.
+ simpl.
+ apply AId.
+ eapply AComp; [ idtac | apply ACanL ].
+ eapply AComp; [ idtac | eapply ALeft; apply IHt2 ].
+ Opaque drop_lev.
+ simpl.
+ Transparent drop_lev.
+ idtac.
+ drop_simplify.
+ apply ARight.
+ apply IHt1.
+ Defined.
+
+ Lemma tree_of_nothing' : forall Γ ec t,
+ Arrange [] (mapOptionTree flatten_leveled_type (drop_lev(Γ:=Γ) (ec :: nil) (t @@@ (ec :: nil)))).
+ intros.
+ induction t; try destruct o; try destruct a.
+ simpl.
+ drop_simplify.
+ simpl.
+ apply AId.
+ simpl.
+ apply AId.
+ eapply AComp; [ apply AuCanL | idtac ].
+ eapply AComp; [ eapply ARight; apply IHt1 | idtac ].
+ Opaque drop_lev.
+ simpl.
+ Transparent drop_lev.
+ idtac.
+ drop_simplify.
+ apply ALeft.
+ apply IHt2.
+ Defined.
+
+ Lemma krunk : forall Γ (ec:HaskTyVar Γ ECKind) t,
+ flatten_type (<[ ec |- t ]>)
+ = @ga_mk Γ (v2t ec)
+ (mapOptionTree flatten_type (take_arg_types_as_tree t))
+ [ flatten_type (drop_arg_types_as_tree t)].
+ intros.
+ unfold flatten_type at 1.
+ simpl.
+ unfold ga_mk.
+ apply phoas_extensionality.
+ intros.
+ unfold v2t.
+ unfold ga_mk_raw.
+ unfold ga_mk_tree.
+ rewrite <- mapOptionTree_compose.
+ unfold take_arg_types_as_tree.
+ simpl.
+ replace (flatten_type (drop_arg_types_as_tree t) tv ite)
+ with (drop_arg_types (flatten_rawtype (t tv ite))).
+ replace (unleaves_ (take_arg_types (flatten_rawtype (t tv ite))))
+ with ((mapOptionTree (fun x : HaskType Γ ★ => flatten_type x tv ite)
+ (unleaves_
+ (take_trustme (count_arg_types (t (fun _ : Kind => unit) (ite_unit Γ)))
+ (fun TV : Kind → Type => take_arg_types ○ t TV))))).
+ reflexivity.
+ unfold flatten_type.
+ clear gar.
+ set (t tv ite) as x.
+ admit.
+ admit.
+ Qed.
+
+ Lemma drop_to_nothing : forall (Γ:TypeEnv) Σ (lev:HaskLevel Γ),
+ drop_lev lev (Σ @@@ lev) = mapTree (fun _ => None) (mapTree (fun _ => tt) Σ).
+ intros.
+ induction Σ.
+ destruct a; simpl.
+ drop_simplify.
+ auto.
+ drop_simplify.
+ auto.
+ simpl.
+ rewrite <- IHΣ1.
+ rewrite <- IHΣ2.
+ reflexivity.
+ Qed.
+
+ Definition flatten_skolemized_proof :
+ forall {h}{c},
+ ND SRule h c ->
+ ND Rule (mapOptionTree (flatten_judgment ) h) (mapOptionTree (flatten_judgment ) c).
+ intros.
+ eapply nd_map'; [ idtac | apply X ].
+ clear h c X.
+ intros.
+ simpl in *.
+
+ refine
+ (match X as R in SRule H C with
+ | SBrak Γ Δ t ec succ lev => let case_SBrak := tt in _
+ | SEsc Γ Δ t ec succ lev => let case_SEsc := tt in _
+ | SFlat h c r => let case_SFlat := tt in _
+ end).
+
+ destruct case_SFlat.
+ refine (match r as R in Rule H C with
+ | RArrange Γ Δ a b x l d => let case_RArrange := tt in _
+ | RNote Γ Δ Σ τ l n => let case_RNote := tt in _
+ | RLit Γ Δ l _ => let case_RLit := tt in _
+ | RVar Γ Δ σ lev => let case_RVar := tt in _
+ | RGlobal Γ Δ σ l wev => let case_RGlobal := tt in _
+ | RLam Γ Δ Σ tx te lev => let case_RLam := tt in _
+ | RCast Γ Δ Σ σ τ lev γ => let case_RCast := tt in _
+ | RAbsT Γ Δ Σ κ σ lev n => let case_RAbsT := tt in _
+ | RAppT Γ Δ Σ κ σ τ lev => let case_RAppT := tt in _
+ | RAppCo Γ Δ Σ κ σ₁ σ₂ γ σ lev => let case_RAppCo := tt in _
+ | RAbsCo Γ Δ Σ κ σ σ₁ σ₂ lev => let case_RAbsCo := tt in _
+ | RApp Γ Δ Σ₁ Σ₂ tx te lev => let case_RApp := tt in _
+ | RCut Γ Δ Σ Σ₁ Σ₁₂ Σ₂ Σ₃ l => let case_RCut := tt in _
+ | RLeft Γ Δ Σ₁ Σ₂ Σ l => let case_RLeft := tt in _
+ | RRight Γ Δ Σ₁ Σ₂ Σ l => let case_RRight := tt in _
+ | RVoid _ _ l => let case_RVoid := tt in _
+ | RBrak Γ Δ t ec succ lev => let case_RBrak := tt in _
+ | REsc Γ Δ t ec succ lev => let case_REsc := tt in _
+ | RCase Γ Δ lev tc Σ avars tbranches alts => let case_RCase := tt in _
+ | RLetRec Γ Δ lri x y t => let case_RLetRec := tt in _
+ end); clear X h c.
+
+ destruct case_RArrange.
+ apply (flatten_arrangement'' Γ Δ a b x _ d).
+
+ destruct case_RBrak.
+ apply (Prelude_error "found unskolemized Brak rule; this shouldn't happen").
+
+ destruct case_REsc.
+ apply (Prelude_error "found unskolemized Esc rule; this shouldn't happen").
+
+ destruct case_RNote.
+ simpl.
+ destruct l; simpl.
+ apply nd_rule; apply RNote; auto.
+ apply nd_rule; apply RNote; auto.
+
+ destruct case_RLit.
+ simpl.
+ destruct l0; simpl.
+ unfold flatten_leveled_type.
+ simpl.
+ rewrite literal_types_unchanged.
+ apply nd_rule; apply RLit.
+ unfold take_lev; simpl.
+ unfold drop_lev; simpl.
+ simpl.
+ rewrite literal_types_unchanged.
+ apply ga_lit.
+
+ destruct case_RVar.
+ Opaque flatten_judgment.
+ simpl.
+ Transparent flatten_judgment.
+ idtac.
+ unfold flatten_judgment.
+ destruct lev.
+ apply nd_rule. apply RVar.
+ repeat drop_simplify.
+ repeat take_simplify.
+ simpl.
+ apply ga_id.
+
+ destruct case_RGlobal.
+ simpl.
+ rename l into g.
+ rename σ into l.
+ destruct l as [|ec lev]; simpl.
+ (*
+ destruct (eqd_dec (g:CoreVar) (hetmet_flatten:CoreVar)).
+ set (flatten_type (g wev)) as t.
+ set (RGlobal _ Δ nil (mkGlobal Γ t hetmet_id)) as q.
+ simpl in q.
+ apply nd_rule.
+ apply q.
+ apply INil.
+ destruct (eqd_dec (g:CoreVar) (hetmet_unflatten:CoreVar)).
+ set (flatten_type (g wev)) as t.
+ set (RGlobal _ Δ nil (mkGlobal Γ t hetmet_id)) as q.
+ simpl in q.
+ apply nd_rule.
+ apply q.
+ apply INil.
+ *)
+ unfold flatten_leveled_type. simpl.
+ apply nd_rule; rewrite globals_do_not_have_code_types.
+ apply RGlobal.
+ apply (Prelude_error "found RGlobal at depth >0; globals should never appear inside code brackets unless escaped").
+
+ destruct case_RLam.
+ Opaque drop_lev.
+ Opaque take_lev.
+ simpl.
+ destruct lev as [|ec lev]; simpl; [ apply nd_rule; apply RLam; auto | idtac ].
+ repeat drop_simplify.
+ repeat take_simplify.
+ eapply nd_comp.
+ eapply nd_rule.
+ eapply RArrange.
+ simpl.
+ apply ACanR.
+ apply boost.
+ simpl.
+ apply ga_curry.
+
+ destruct case_RCast.
+ simpl.
+ destruct lev as [|ec lev]; simpl; [ apply nd_rule; apply RCast; auto | idtac ].
+ simpl.
+ apply flatten_coercion; auto.
+ apply (Prelude_error "RCast at level >0; casting inside of code brackets is currently not supported").
+
+ destruct case_RApp.
+ simpl.
+
+ destruct lev as [|ec lev].
+ unfold flatten_type at 1.
+ simpl.
+ apply nd_rule.
+ apply RApp.
+
+ repeat drop_simplify.
+ repeat take_simplify.
+ rewrite mapOptionTree_distributes.
+ set (mapOptionTree (flatten_leveled_type ) (drop_lev (ec :: lev) Σ₁)) as Σ₁'.
+ set (mapOptionTree (flatten_leveled_type ) (drop_lev (ec :: lev) Σ₂)) as Σ₂'.
+ set (take_lev (ec :: lev) Σ₁) as Σ₁''.
+ set (take_lev (ec :: lev) Σ₂) as Σ₂''.
+ replace (flatten_type (tx ---> te)) with ((flatten_type tx) ---> (flatten_type te)).
+ apply (Prelude_error "FIXME: ga_apply").
+ reflexivity.
+
+(*
+ Notation "` x" := (take_lev _ x).
+ Notation "`` x" := (mapOptionTree unlev x) (at level 20).
+ Notation "``` x" := ((drop_lev _ x)) (at level 20).
+ Notation "!<[]> x" := (flatten_type _ x) (at level 1).
+ Notation "!<[@]> x" := (mapOptionTree flatten_leveled_type x) (at level 1).
+*)
+
+ destruct case_RCut.
+ simpl.
+ destruct l as [|ec lev]; simpl.
+ apply nd_rule.
+ replace (mapOptionTree flatten_leveled_type (Σ₁₂ @@@ nil)) with (mapOptionTree flatten_type Σ₁₂ @@@ nil).
+ apply RCut.
+ induction Σ₁₂; try destruct a; auto.
+ simpl.
+ rewrite <- IHΣ₁₂1.
+ rewrite <- IHΣ₁₂2.
+ reflexivity.
+ simpl; repeat drop_simplify.
+ simpl; repeat take_simplify.
+ simpl.
+ set (drop_lev (ec :: lev) (Σ₁₂ @@@ (ec :: lev))) as x1.
+ rewrite take_lemma'.
+ rewrite mapOptionTree_compose.
+ rewrite mapOptionTree_compose.
+ rewrite mapOptionTree_compose.
+ rewrite mapOptionTree_compose.
+ rewrite unlev_relev.
+ rewrite <- mapOptionTree_compose.
+ rewrite <- mapOptionTree_compose.
+ rewrite <- mapOptionTree_compose.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RCut ].
+ apply nd_prod.
+ apply nd_id.
+ eapply nd_comp.
+ eapply nd_rule.
+ eapply RArrange.
+ eapply ALeft.
+ eapply ARight.
+ unfold x1.
+ rewrite drop_to_nothing.
+ apply arrangeCancelEmptyTree with (q:=(mapTree (fun _ : ??(HaskType Γ ★) => tt) Σ₁₂)).
+ induction Σ₁₂; try destruct a; auto.
+ simpl.
+ rewrite <- IHΣ₁₂1 at 2.
+ rewrite <- IHΣ₁₂2 at 2.
+ reflexivity.
+ eapply nd_comp; [ eapply nd_rule; eapply RArrange; eapply ALeft; eapply ACanL | idtac ].
+ set (mapOptionTree flatten_type Σ₁₂) as a.
+ set (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) Σ₁)) as b.
+ set (mapOptionTree flatten_leveled_type (drop_lev (ec :: lev) Σ₂)) as c.
+ set (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) Σ₂)) as d.
+ set (mapOptionTree flatten_leveled_type (drop_lev (ec :: lev) Σ)) as e.
+ set (mapOptionTree (flatten_type ○ unlev) (take_lev (ec :: lev) Σ)) as f.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RCut ].
+ eapply nd_comp; [ apply nd_llecnac | idtac ].
+ apply nd_prod.
+ simpl.
+ eapply secondify.
+ apply ga_first.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply ALeft; eapply AExch ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AuAssoc ].
+ simpl.
+ apply precompose.
+
+ destruct case_RLeft.
+ simpl.
+ destruct l as [|ec lev].
+ simpl.
+ replace (mapOptionTree flatten_leveled_type (Σ @@@ nil)) with (mapOptionTree flatten_type Σ @@@ nil).
+ apply nd_rule.
+ apply RLeft.
+ induction Σ; try destruct a; auto.
+ simpl.
+ rewrite <- IHΣ1.
+ rewrite <- IHΣ2.
+ reflexivity.
+ repeat drop_simplify.
+ rewrite drop_to_nothing.
+ simpl.
+ eapply nd_comp.
+ Focus 2.
+ eapply nd_rule.
+ eapply RArrange.
+ eapply ARight.
+ apply arrangeUnCancelEmptyTree with (q:=(mapTree (fun _ : ??(HaskType Γ ★) => tt) Σ)).
+ induction Σ; try destruct a; auto.
+ simpl.
+ rewrite <- IHΣ1 at 2.
+ rewrite <- IHΣ2 at 2.
+ reflexivity.
+ idtac.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AuCanL ].
+ apply boost.
+ take_simplify.
+ simpl.
+ replace (take_lev (ec :: lev) (Σ @@@ (ec :: lev))) with (Σ @@@ (ec::lev)).
+ rewrite mapOptionTree_compose.
+ rewrite mapOptionTree_compose.
+ rewrite unlev_relev.
+ apply ga_second.
+ rewrite take_lemma'.
+ reflexivity.
+
+ destruct case_RRight.
+ simpl.
+ destruct l as [|ec lev].
+ simpl.
+ replace (mapOptionTree flatten_leveled_type (Σ @@@ nil)) with (mapOptionTree flatten_type Σ @@@ nil).
+ apply nd_rule.
+ apply RRight.
+ induction Σ; try destruct a; auto.
+ simpl.
+ rewrite <- IHΣ1.
+ rewrite <- IHΣ2.
+ reflexivity.
+ repeat drop_simplify.
+ rewrite drop_to_nothing.
+ simpl.
+ eapply nd_comp.
+ Focus 2.
+ eapply nd_rule.
+ eapply RArrange.
+ eapply ALeft.
+ apply arrangeUnCancelEmptyTree with (q:=(mapTree (fun _ : ??(HaskType Γ ★) => tt) Σ)).
+ induction Σ; try destruct a; auto.
+ simpl.
+ rewrite <- IHΣ1 at 2.
+ rewrite <- IHΣ2 at 2.
+ reflexivity.
+ idtac.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AuCanR ].
+ apply boost.
+ take_simplify.
+ simpl.
+ replace (take_lev (ec :: lev) (Σ @@@ (ec :: lev))) with (Σ @@@ (ec::lev)).
+ rewrite mapOptionTree_compose.
+ rewrite mapOptionTree_compose.
+ rewrite unlev_relev.
+ apply ga_first.
+ rewrite take_lemma'.
+ reflexivity.
+
+ destruct case_RVoid.
+ simpl.
+ destruct l.
+ apply nd_rule.
+ apply RVoid.
+ drop_simplify.
+ take_simplify.
+ simpl.
+ apply ga_id.
+
+ destruct case_RAppT.
+ simpl. destruct lev; simpl.
+ unfold flatten_leveled_type.
+ simpl.
+ rewrite flatten_commutes_with_HaskTAll.
+ rewrite flatten_commutes_with_substT.
+ apply nd_rule.
+ apply RAppT.
+ apply Δ.
+ apply Δ.
+ apply (Prelude_error "found type application at level >0; this is not supported").
+
+ destruct case_RAbsT.
+ simpl. destruct lev; simpl.
+ rewrite flatten_commutes_with_HaskTAll.
+ rewrite flatten_commutes_with_HaskTApp.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RAbsT ].
+ simpl.
+ set (mapOptionTree (flatten_leveled_type ) (mapOptionTree (weakLT_(n:=n)(κ:=κ)) Σ)) as a.
+ set (mapOptionTree (weakLT_(n:=n)(κ:=κ)) (mapOptionTree (flatten_leveled_type ) Σ)) as q'.
+ assert (a=q').
+ unfold a.
+ unfold q'.
+ clear a q'.
+ induction Σ.
+ destruct a.
+ simpl.
+ rewrite flatten_commutes_with_weakLT.
+ reflexivity.
+ reflexivity.
+ simpl.
+ rewrite <- IHΣ1.
+ rewrite <- IHΣ2.
+ reflexivity.
+ rewrite H.
+ apply nd_id.
+ apply Δ.
+ apply Δ.
+ apply (Prelude_error "found type abstraction at level >0; this is not supported").
+
+ destruct case_RAppCo.
+ simpl. destruct lev; simpl.
+ unfold flatten_type.
+ simpl.
+ apply nd_rule.
+ apply RAppCo.
+ apply flatten_coercion.
+ apply γ.
+ apply (Prelude_error "found coercion application at level >0; this is not supported").
+
+ destruct case_RAbsCo.
+ simpl. destruct lev; simpl.
+ unfold flatten_type.
+ simpl.
+ apply (Prelude_error "AbsCo not supported (FIXME)").
+ apply (Prelude_error "found coercion abstraction at level >0; this is not supported").
+
+ destruct case_RLetRec.
+ rename t into lev.
+ simpl. destruct lev; simpl.
+ apply nd_rule.
+ set (@RLetRec Γ Δ (mapOptionTree flatten_leveled_type lri) (flatten_type x) (mapOptionTree flatten_type y) nil) as q.
+ replace (mapOptionTree flatten_leveled_type (y @@@ nil)) with (mapOptionTree flatten_type y @@@ nil).
+ apply q.
+ induction y; try destruct a; auto.
+ simpl.
+ rewrite IHy1.
+ rewrite IHy2.
+ reflexivity.
+ repeat drop_simplify.
+ repeat take_simplify.
+ simpl.
+ rewrite drop_to_nothing.
+ eapply nd_comp.
+ eapply nd_rule.
+ eapply RArrange.
+ eapply AComp.
+ eapply ARight.
+ apply arrangeCancelEmptyTree with (q:=y).
+ induction y; try destruct a; auto.
+ simpl.
+ rewrite <- IHy1.
+ rewrite <- IHy2.
+ reflexivity.
+ apply ACanL.
+ rewrite take_lemma'.
+ set (mapOptionTree (flatten_type ○ unlev) (take_lev (h :: lev) lri)) as lri'.
+ set (mapOptionTree flatten_leveled_type (drop_lev (h :: lev) lri)) as lri''.
+ replace (mapOptionTree (flatten_type ○ unlev) (y @@@ (h :: lev))) with (mapOptionTree flatten_type y).
+ apply boost.
+ apply ga_loopl.
+ rewrite <- mapOptionTree_compose.
+ simpl.
+ reflexivity.
+
+ destruct case_RCase.
+ destruct lev; [ idtac | apply (Prelude_error "case at depth >0") ]; simpl.
+ apply nd_rule.
+ rewrite <- mapOptionTree_compose.
+ replace (mapOptionTree
+ (fun x => flatten_judgment (pcb_judg (snd x)))
+ alts,, [Γ > Δ > mapOptionTree flatten_leveled_type Σ |- [flatten_type (caseType tc avars)] @ nil])
+ with
+ (mapOptionTree
+ (fun x => @pcb_judg tc Γ Δ nil (flatten_type tbranches) avars (fst x) (snd x))
+ alts,,
+ [Γ > Δ > mapOptionTree flatten_leveled_type Σ |- [caseType tc avars] @ nil]).
+ replace (mapOptionTree flatten_leveled_type
+ (mapOptionTreeAndFlatten
+ (fun x => (snd x)) alts))
+ with (mapOptionTreeAndFlatten
+ (fun x =>
+ (snd x)) alts).
+ apply RCase.
+ admit.
+ admit.
+
+ destruct case_SBrak.
+ simpl.
+ destruct lev.
+ drop_simplify.
+ set (drop_lev (ec :: nil) (take_arg_types_as_tree t @@@ (ec :: nil))) as empty_tree.
+ take_simplify.
+ rewrite take_lemma'.
+ simpl.
+ rewrite mapOptionTree_compose.
+ rewrite mapOptionTree_compose.
+ rewrite unlev_relev.
+ rewrite <- mapOptionTree_compose.
+ simpl.
+ rewrite krunk.
+ set (mapOptionTree flatten_leveled_type (drop_lev (ec :: nil) succ)) as succ_host.
+ set (mapOptionTree (flatten_type ○ unlev)(take_lev (ec :: nil) succ)) as succ_guest.
+ set (mapOptionTree flatten_type (take_arg_types_as_tree t)) as succ_args.
+ unfold empty_tree.
+ eapply nd_comp; [ eapply nd_rule; eapply RArrange; eapply ALeft; apply tree_of_nothing | idtac ].
+ eapply nd_comp; [ eapply nd_rule; eapply RArrange; eapply ACanR | idtac ].
+ refine (ga_unkappa Γ Δ (v2t ec) nil _ _ _ _ ;; _).
+ eapply nd_comp; [ idtac | eapply arrange_brak ].
+ unfold succ_host.
+ unfold succ_guest.
+ eapply nd_rule.
+ eapply RArrange.
+ apply AExch.
+ apply (Prelude_error "found Brak at depth >0 indicating 3-level code; only two-level code is currently supported").
+
+ destruct case_SEsc.
+ simpl.
+ destruct lev.
+ simpl.
+ unfold flatten_leveled_type at 2.
+ simpl.
+ rewrite krunk.
+ rewrite mapOptionTree_compose.
+ take_simplify.
+ drop_simplify.
+ simpl.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply ALeft; apply tree_of_nothing' ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply ACanR ].
+ simpl.
+ rewrite take_lemma'.
+ rewrite unlev_relev.
+ rewrite <- mapOptionTree_compose.
+ eapply nd_comp; [ apply (arrange_esc _ _ ec) | idtac ].
+
+ set (decide_tree_empty (take_lev (ec :: nil) succ)) as q'.
+ destruct q'.
+ destruct s.
+ rewrite e.
+ clear e.
+
+ set (mapOptionTree flatten_leveled_type (drop_lev (ec :: nil) succ)) as succ_host.
+ set (mapOptionTree flatten_type (take_arg_types_as_tree t)) as succ_args.
+
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; apply AuCanR ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; apply AuCanR ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; apply ACanL ].
+ eapply nd_comp; [ idtac | eapply RLet ].
+ eapply nd_comp; [ apply nd_llecnac | idtac ].
+ apply nd_prod; [ idtac | eapply boost ].
+ induction x.
+ apply ga_id.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply ACanL ].
+ simpl.
+ apply ga_join.
+ apply IHx1.
+ apply IHx2.
+ simpl.
+ apply postcompose.
+
+ refine ( _ ;; (boost _ _ _ _ _ (postcompose _ _ _ _ _ _ _ _))).
+ apply ga_cancell.
+ apply firstify.
+
+ induction x.
+ destruct a; simpl.
+ apply ga_id.
+ simpl.
+ refine ( _ ;; (boost _ _ _ _ _ (postcompose _ _ _ _ _ _ _ _))).
+ apply ga_cancell.
+ refine ( _ ;; (boost _ _ _ _ _ (postcompose _ _ _ _ _ _ _ _))).
+ eapply firstify.
+ apply IHx1.
+ apply secondify.
+ apply IHx2.
+
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AuCanR ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply AuCanR ].
+
+ replace (mapOptionTree (fun ht => levels_to_tcode (unlev ht) (getlev ht) @@ nil) (drop_lev (ec :: nil) succ))
+ with (mapOptionTree flatten_leveled_type (drop_lev (ec :: nil) succ)).
+ eapply nd_comp; [ eapply nd_rule; eapply RArrange; eapply AExch | idtac ].
+ apply ga_kappa.
+ induction succ.
+ destruct a.
+ destruct l.
+ Transparent drop_lev.
+ simpl.
+ unfold drop_lev.
+ Opaque drop_lev.
+ unfold mkDropFlags.
+ simpl.
+ destruct (General.list_eq_dec h1 (ec :: nil)).
+ simpl.
+ auto.
+ simpl.
+ unfold flatten_leveled_type.
+ simpl.
+ auto.
+ simpl.
+ auto.
+ simpl.
+ drop_simplify.
+ simpl.
+ rewrite IHsucc1.
+ rewrite IHsucc2.
+ reflexivity.
+
+ (* nesting too deep *)
+ apply (Prelude_error "found Esc at depth >0 indicating 3-level code; only two-level code is currently supported").
+ Defined.
+
+ Definition flatten_proof :
+ forall {h}{c},
+ ND Rule h c ->
+ ND Rule h c.
+ apply (Prelude_error "sorry, non-skolemized flattening isn't implemented").
+ Defined.
+
+ Definition skolemize_and_flatten_proof :
+ forall {h}{c},
+ ND Rule h c ->
+ ND Rule
+ (mapOptionTree (flatten_judgment ○ skolemize_judgment) h)
+ (mapOptionTree (flatten_judgment ○ skolemize_judgment) c).
+ intros.
+ rewrite mapOptionTree_compose.
+ rewrite mapOptionTree_compose.
+ apply flatten_skolemized_proof.
+ apply skolemize_proof.
+ apply X.
+ Defined.
+
+
+ (* to do: establish some metric on judgments (max length of level of any succedent type, probably), show how to
+ * calculate it, and show that the flattening procedure above drives it down by one *)
+
+ (*
+ Instance FlatteningFunctor {Γ}{Δ}{ec} : Functor (JudgmentsL (PCF Γ Δ ec)) (TypesL (SystemFCa Γ Δ)) (obact) :=
+ { fmor := FlatteningFunctor_fmor }.
+
+ Definition ReificationFunctor Γ Δ : Functor (JudgmentsL _ _ (PCF n Γ Δ)) SystemFCa' (mapOptionTree brakifyJudg).
+ refine {| fmor := ReificationFunctor_fmor Γ Δ |}; unfold hom; unfold ob; simpl ; intros.
+
+ Definition PCF_SMME (n:nat)(Γ:TypeEnv)(Δ:CoercionEnv Γ) : ProgrammingLanguageSMME.
+ refine {| plsmme_pl := PCF n Γ Δ |}.
+ Defined.
+
+ Definition SystemFCa_SMME (n:nat)(Γ:TypeEnv)(Δ:CoercionEnv Γ) : ProgrammingLanguageSMME.
+ refine {| plsmme_pl := SystemFCa n Γ Δ |}.
+ Defined.
+
+ Definition ReificationFunctorMonoidal n : MonoidalFunctor (JudgmentsN n) (JudgmentsN (S n)) (ReificationFunctor n).
+ Defined.
+
+ (* 5.1.4 *)
+ Definition PCF_SystemFCa_two_level n Γ Δ : TwoLevelLanguage (PCF_SMME n Γ Δ) (SystemFCa_SMME (S n) Γ Δ).
+ Defined.
+ *)
+ (* ... and the retraction exists *)
+
+End HaskFlattener.
+
+Implicit Arguments garrow [ ].
Notation "'★'" := KindStar.
Notation "a ⇛ b" := (KindArrow a b).
+(* the kind of environment classifiers *)
+Definition ECKind := ★ ⇛ ★ ⇛ ★.
+Opaque ECKind.
+
Fixpoint kindToLatexMath (k:Kind) : LatexMath :=
match k with
| ★ => rawLatexMath "\star"
(*********************************************************************************************************************************)
-(* HaskLiteralsAndTyCons: representation of compile-time constants (literals) *)
+(* HaskLiterals: representation of compile-time constants (literals) *)
(*********************************************************************************************************************************)
Generalizable All Variables.
Require Import General.
Require Import Coq.Strings.String.
Require Import HaskKinds.
-
-Variable CoreDataCon : Type. Extract Inlined Constant CoreDataCon => "DataCon.DataCon".
-
-(* once again, we pull the trick of having multiple Coq types map to a single Haskell type to provide stronger typing *)
-Variable TyCon : Type. Extract Inlined Constant TyCon => "TyCon.TyCon".
-Variable TyFun : Type. Extract Inlined Constant TyFun => "TyCon.TyCon".
+Require Import HaskTyCons.
(* Since GHC is written in Haskell, compile-time Haskell constants are represented using Haskell (Prelude) types *)
Variable HaskInt : Type. Extract Inlined Constant HaskInt => "Prelude.Int".
Variable HaskInteger : Type. Extract Inlined Constant HaskInteger => "Prelude.Integer".
Variable HaskRational : Type. Extract Inlined Constant HaskRational => "Prelude.Rational".
-Variable CoreName : Type. Extract Inlined Constant CoreName => "Name.Name".
-Variable Class_ : Type. Extract Inlined Constant Class_ => "Class.Class".
-Variable CoreIPName : Type -> Type. Extract Constant CoreIPName "’a" => "BasicTypes.IPName".
- Extraction Inline CoreIPName.
-
(* This type extracts exactly onto GHC's Literal.Literal type *)
Inductive HaskLiteral :=
| HaskMachChar : HaskChar -> HaskLiteral
| HaskMachDouble _ => doublePrimTyCon
| HaskMachLabel _ _ _ => addrPrimTyCon
end.
-
-Variable tyConToString : TyCon -> string. Extract Inlined Constant tyConToString => "outputableToString".
-Variable tyFunToString : TyFun -> string. Extract Inlined Constant tyFunToString => "outputableToString".
-Instance TyConToString : ToString TyCon := { toString := tyConToString }.
-Instance TyFunToString : ToString TyFun := { toString := tyFunToString }.
-Instance TyConToLatex : ToLatex TyCon := { toLatex := fun x => toLatex (toString x) }.
-Instance TyFunToLatex : ToLatex TyCon := { toLatex := fun x => toLatex (toString x) }.
-
-Variable ModalBoxTyCon : TyCon. Extract Inlined Constant ModalBoxTyCon => "TysWiredIn.hetMetCodeTypeTyCon".
-Variable ArrowTyCon : TyCon. Extract Constant ArrowTyCon => "Type.funTyCon".
--- /dev/null
+(*********************************************************************************************************************************)
+(* HaskProgrammingLanguage: *)
+(* *)
+(* System FC^\alpha is a ProgrammingLanguage. *)
+(* *)
+(*********************************************************************************************************************************)
+
+Generalizable All Variables.
+Require Import Preamble.
+Require Import General.
+Require Import NaturalDeduction.
+Require Import Coq.Strings.String.
+Require Import Coq.Lists.List.
+
+Require Import Algebras_ch4.
+Require Import Categories_ch1_3.
+Require Import Functors_ch1_4.
+Require Import Isomorphisms_ch1_5.
+Require Import ProductCategories_ch1_6_1.
+Require Import OppositeCategories_ch1_6_2.
+Require Import Enrichment_ch2_8.
+Require Import Subcategories_ch7_1.
+Require Import NaturalTransformations_ch7_4.
+Require Import NaturalIsomorphisms_ch7_5.
+Require Import MonoidalCategories_ch7_8.
+Require Import Coherence_ch7_8.
+
+Require Import HaskKinds.
+Require Import HaskCoreTypes.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
+Require Import HaskStrongTypes.
+Require Import HaskProof.
+Require Import NaturalDeduction.
+Require Import NaturalDeductionCategory.
+
+Require Import HaskStrongTypes.
+Require Import HaskStrong.
+Require Import HaskProof.
+Require Import HaskStrongToProof.
+Require Import HaskProofToStrong.
+Require Import ProgrammingLanguage.
+
+Open Scope nd_scope.
+
+(* The judgments any specific Γ,Δ form a category with proofs as morphisms *)
+Section HaskProgrammingLanguage.
+
+ Context (ndr_systemfc:@ND_Relation _ Rule).
+
+ Context Γ (Δ:CoercionEnv Γ).
+
+
+ Definition JudgΓΔ := prod (Tree ??(LeveledHaskType Γ ★)) (Tree ??(LeveledHaskType Γ ★)).
+
+ Definition RuleΓΔ : Tree ??JudgΓΔ -> Tree ??JudgΓΔ -> Type :=
+ fun h c =>
+ Rule
+ (mapOptionTree (fun j => Γ > Δ > fst j |- snd j) h)
+ (mapOptionTree (fun j => Γ > Δ > fst j |- snd j) c).
+
+ Definition SystemFCa_cut : forall a b c, ND RuleΓΔ ([(a,b)],,[(b,c)]) [(a,c)].
+ intros.
+ destruct b.
+ destruct o.
+ destruct c.
+ destruct o.
+
+ (* when the cut is a single leaf and the RHS is a single leaf: *)
+ (*
+ eapply nd_comp.
+ eapply nd_prod.
+ apply nd_id.
+ eapply nd_rule.
+ set (@org_fc) as ofc.
+ set (RArrange Γ Δ _ _ _ (AuCanL [l0])) as rule.
+ apply org_fc with (r:=RArrange _ _ _ _ _ (AuCanL [_])).
+ auto.
+ eapply nd_comp; [ idtac | eapply nd_rule; apply org_fc with (r:=RArrange _ _ _ _ _ (ACanL _)) ].
+ apply nd_rule.
+ destruct l.
+ destruct l0.
+ assert (h0=h2). admit.
+ subst.
+ apply org_fc with (r:=@RLet Γ Δ [] a h1 h h2).
+ auto.
+ auto.
+ *)
+ admit.
+ apply (Prelude_error "systemfc cut rule invoked with [a|=[b]] [[b]|=[]]").
+ apply (Prelude_error "systemfc cut rule invoked with [a|=[b]] [[b]|=[x,,y]]").
+ apply (Prelude_error "systemfc rule invoked with [a|=[]] [[]|=c]").
+ apply (Prelude_error "systemfc rule invoked with [a|=[b,,c]] [[b,,c]|=z]").
+ Defined.
+
+ Instance SystemFCa_sequents : @SequentND _ RuleΓΔ _ _ :=
+ { snd_cut := SystemFCa_cut }.
+ apply Build_SequentND.
+ intros.
+ induction a.
+ destruct a; simpl.
+ (*
+ apply nd_rule.
+ destruct l.
+ apply org_fc with (r:=RVar _ _ _ _).
+ auto.
+ apply nd_rule.
+ apply org_fc with (r:=RVoid _ _ ).
+ auto.
+ eapply nd_comp.
+ eapply nd_comp; [ apply nd_llecnac | idtac ].
+ apply (nd_prod IHa1 IHa2).
+ apply nd_rule.
+ apply org_fc with (r:=RJoin _ _ _ _ _ _).
+ auto.
+ admit.
+ *)
+ admit.
+ admit.
+ admit.
+ admit.
+ Defined.
+
+ Definition SystemFCa_left a b c : ND RuleΓΔ [(b,c)] [((a,,b),(a,,c))].
+ admit.
+ (*
+ eapply nd_comp; [ apply nd_llecnac | eapply nd_comp; [ idtac | idtac ] ].
+ eapply nd_prod; [ apply snd_initial | apply nd_id ].
+ apply nd_rule.
+ apply org_fc with (r:=RJoin Γ Δ a b a c).
+ auto.
+ *)
+ Defined.
+
+ Definition SystemFCa_right a b c : ND RuleΓΔ [(b,c)] [((b,,a),(c,,a))].
+ admit.
+ (*
+ eapply nd_comp; [ apply nd_rlecnac | eapply nd_comp; [ idtac | idtac ] ].
+ eapply nd_prod; [ apply nd_id | apply snd_initial ].
+ apply nd_rule.
+ apply org_fc with (r:=RJoin Γ Δ b a c a).
+ auto.
+ *)
+ Defined.
+
+ Instance SystemFCa_sequent_join : @ContextND _ _ _ _ SystemFCa_sequents :=
+ { cnd_expand_left := fun a b c => SystemFCa_left c a b
+ ; cnd_expand_right := fun a b c => SystemFCa_right c a b }.
+ (*
+ intros; apply nd_rule. simpl.
+ apply (org_fc _ _ _ _ ((RArrange _ _ _ _ _ (AuAssoc _ _ _)))).
+ auto.
+
+ intros; apply nd_rule. simpl.
+ apply (org_fc _ _ _ _ (RArrange _ _ _ _ _ (AAssoc _ _ _))); auto.
+
+ intros; apply nd_rule. simpl.
+ apply (org_fc _ _ _ _ (RArrange _ _ _ _ _ (ACanL _))); auto.
+
+ intros; apply nd_rule. simpl.
+ apply (org_fc _ _ _ _ (RArrange _ _ _ _ _ (ACanR _))); auto.
+
+ intros; apply nd_rule. simpl.
+ apply (org_fc _ _ _ _ (RArrange _ _ _ _ _ (AuCanL _))); auto.
+
+ intros; apply nd_rule. simpl.
+ apply (org_fc _ _ _ _ (RArrange _ _ _ _ _ (AuCanR _))); auto.
+ *)
+ admit.
+ admit.
+ admit.
+ admit.
+ admit.
+ admit.
+ Defined.
+
+ Instance OrgFC : @ND_Relation _ RuleΓΔ.
+ Admitted.
+
+ Instance OrgFC_SequentND_Relation : SequentND_Relation SystemFCa_sequent_join OrgFC.
+ admit.
+ Defined.
+
+ Definition OrgFC_ContextND_Relation
+ : @ContextND_Relation _ _ _ _ _ SystemFCa_sequent_join OrgFC OrgFC_SequentND_Relation.
+ admit.
+ Defined.
+
+ (* 5.1.2 *)
+ Instance SystemFCa : @ProgrammingLanguage (LeveledHaskType Γ ★) _ :=
+ { pl_eqv := OrgFC_ContextND_Relation
+ ; pl_snd := SystemFCa_sequents
+ }.
+
+End HaskProgrammingLanguage.
Require Import Preamble.
Require Import General.
Require Import NaturalDeduction.
+Require Import NaturalDeductionContext.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import HaskKinds.
Require Import HaskCoreTypes.
-Require Import HaskLiteralsAndTyCons.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
Require Import HaskStrongTypes.
Require Import HaskWeakVars.
forall Γ:TypeEnv,
forall Δ:CoercionEnv Γ,
Tree ??(LeveledHaskType Γ ★) ->
- Tree ??(LeveledHaskType Γ ★) ->
+ Tree ??(HaskType Γ ★) ->
+ HaskLevel Γ ->
Judg.
- Notation "Γ > Δ > a '|-' s" := (mkJudg Γ Δ a s) (at level 52, Δ at level 50, a at level 52, s at level 50).
+ Notation "Γ > Δ > a '|-' s '@' l" := (mkJudg Γ Δ a s l) (at level 52, Δ at level 50, a at level 52, s at level 50, l at level 50).
(* information needed to define a case branch in a HaskProof *)
-Record ProofCaseBranch {tc:TyCon}{Γ}{Δ}{lev}{branchtype : HaskType Γ ★}{avars}{sac:@StrongAltCon tc} :=
-{ pcb_freevars : Tree ??(LeveledHaskType Γ ★)
-; pcb_judg := sac_Γ sac Γ > sac_Δ sac Γ avars (map weakCK' Δ)
+Definition pcb_judg
+ {tc:TyCon}{Γ}{Δ}{lev}{branchtype : HaskType Γ ★}{avars}{sac:@StrongAltCon tc}
+ (pcb_freevars : Tree ??(LeveledHaskType Γ ★)) :=
+ sac_gamma sac Γ > sac_delta sac Γ avars (map weakCK' Δ)
> (mapOptionTree weakLT' pcb_freevars),,(unleaves (map (fun t => t@@weakL' lev)
(vec2list (sac_types sac Γ avars))))
- |- [weakLT' (branchtype @@ lev)]
-}.
-Implicit Arguments ProofCaseBranch [ ].
-
-(* Figure 3, production $\vdash_E$, Uniform rules *)
-Inductive Arrange {T} : Tree ??T -> Tree ??T -> Type :=
-| RCanL : forall a , Arrange ( [],,a ) ( a )
-| RCanR : forall a , Arrange ( a,,[] ) ( a )
-| RuCanL : forall a , Arrange ( a ) ( [],,a )
-| RuCanR : forall a , Arrange ( a ) ( a,,[] )
-| RAssoc : forall a b c , Arrange (a,,(b,,c) ) ((a,,b),,c )
-| RCossa : forall a b c , Arrange ((a,,b),,c ) ( a,,(b,,c) )
-| RExch : forall a b , Arrange ( (b,,a) ) ( (a,,b) )
-| RWeak : forall a , Arrange ( [] ) ( a )
-| RCont : forall a , Arrange ( (a,,a) ) ( a )
-| RLeft : forall {h}{c} x , Arrange h c -> Arrange ( x,,h ) ( x,,c)
-| RRight : forall {h}{c} x , Arrange h c -> Arrange ( h,,x ) ( c,,x)
-| RComp : forall {a}{b}{c}, Arrange a b -> Arrange b c -> Arrange a c
-.
+ |- [weakT' branchtype ] @ weakL' lev.
(* Figure 3, production $\vdash_E$, all rules *)
Inductive Rule : Tree ??Judg -> Tree ??Judg -> Type :=
-| RArrange : ∀ Γ Δ Σ₁ Σ₂ Σ, Arrange Σ₁ Σ₂ -> Rule [Γ > Δ > Σ₁ |- Σ ] [Γ > Δ > Σ₂ |- Σ ]
+| RArrange : ∀ Γ Δ Σ₁ Σ₂ Σ l, Arrange Σ₁ Σ₂ -> Rule [Γ > Δ > Σ₁ |- Σ @l] [Γ > Δ > Σ₂ |- Σ @l]
(* λ^α rules *)
-| RBrak : ∀ Γ Δ t v Σ l, Rule [Γ > Δ > Σ |- [t @@ (v::l) ]] [Γ > Δ > Σ |- [<[v|-t]> @@l]]
-| REsc : ∀ Γ Δ t v Σ l, Rule [Γ > Δ > Σ |- [<[v|-t]> @@ l]] [Γ > Δ > Σ |- [t @@ (v::l)]]
+| RBrak : ∀ Γ Δ t v Σ l, Rule [Γ > Δ > Σ |- [t]@(v::l) ] [Γ > Δ > Σ |- [<[v|-t]> ] @l]
+| REsc : ∀ Γ Δ t v Σ l, Rule [Γ > Δ > Σ |- [<[v|-t]> ] @l] [Γ > Δ > Σ |- [t]@(v::l) ]
(* Part of GHC, but not explicitly in System FC *)
-| RNote : ∀ Γ Δ Σ τ l, Note -> Rule [Γ > Δ > Σ |- [τ @@ l]] [Γ > Δ > Σ |- [τ @@l]]
-| RLit : ∀ Γ Δ v l, Rule [ ] [Γ > Δ > []|- [literalType v @@l]]
+| RNote : ∀ Γ Δ Σ τ l, Note -> Rule [Γ > Δ > Σ |- [τ ] @l] [Γ > Δ > Σ |- [τ ] @l]
+| RLit : ∀ Γ Δ v l, Rule [ ] [Γ > Δ > []|- [literalType v ] @l]
(* SystemFC rules *)
-| RVar : ∀ Γ Δ σ l, Rule [ ] [Γ>Δ> [σ@@l] |- [σ @@l]]
-| RGlobal : ∀ Γ Δ τ l, WeakExprVar -> Rule [ ] [Γ>Δ> [] |- [τ @@l]]
-| RLam : forall Γ Δ Σ (tx:HaskType Γ ★) te l, Rule [Γ>Δ> Σ,,[tx@@l]|- [te@@l] ] [Γ>Δ> Σ |- [tx--->te @@l]]
+| RVar : ∀ Γ Δ σ l, Rule [ ] [Γ>Δ> [σ@@l] |- [σ ] @l]
+| RGlobal : forall Γ Δ l (g:Global Γ) v, Rule [ ] [Γ>Δ> [] |- [g v ] @l]
+| RLam : forall Γ Δ Σ (tx:HaskType Γ ★) te l, Rule [Γ>Δ> Σ,,[tx@@l]|- [te] @l] [Γ>Δ> Σ |- [tx--->te ] @l]
| RCast : forall Γ Δ Σ (σ₁ σ₂:HaskType Γ ★) l,
- HaskCoercion Γ Δ (σ₁∼∼∼σ₂) -> Rule [Γ>Δ> Σ |- [σ₁@@l] ] [Γ>Δ> Σ |- [σ₂ @@l]]
+ HaskCoercion Γ Δ (σ₁∼∼∼σ₂) -> Rule [Γ>Δ> Σ |- [σ₁] @l] [Γ>Δ> Σ |- [σ₂ ] @l]
-| RJoin : ∀ Γ Δ Σ₁ Σ₂ τ₁ τ₂ , Rule ([Γ > Δ > Σ₁ |- τ₁ ],,[Γ > Δ > Σ₂ |- τ₂ ]) [Γ>Δ> Σ₁,,Σ₂ |- τ₁,,τ₂ ]
+(* order is important here; we want to be able to skolemize without introducing new AExch'es *)
+| RApp : ∀ Γ Δ Σ₁ Σ₂ tx te l, Rule ([Γ>Δ> Σ₁ |- [tx--->te]@l],,[Γ>Δ> Σ₂ |- [tx]@l]) [Γ>Δ> Σ₁,,Σ₂ |- [te]@l]
-| RApp : ∀ Γ Δ Σ₁ Σ₂ tx te l, Rule ([Γ>Δ> Σ₁ |- [tx--->te @@l]],,[Γ>Δ> Σ₂ |- [tx@@l]]) [Γ>Δ> Σ₁,,Σ₂ |- [te @@l]]
+| RCut : ∀ Γ Δ Σ Σ₁ Σ₁₂ Σ₂ Σ₃ l, Rule ([Γ>Δ> Σ₁ |- Σ₁₂ @l],,[Γ>Δ> Σ,,((Σ₁₂@@@l),,Σ₂) |- Σ₃@l ]) [Γ>Δ> Σ,,(Σ₁,,Σ₂) |- Σ₃@l]
+| RLeft : ∀ Γ Δ Σ₁ Σ₂ Σ l, Rule [Γ>Δ> Σ₁ |- Σ₂ @l] [Γ>Δ> (Σ@@@l),,Σ₁ |- Σ,,Σ₂@l]
+| RRight : ∀ Γ Δ Σ₁ Σ₂ Σ l, Rule [Γ>Δ> Σ₁ |- Σ₂ @l] [Γ>Δ> Σ₁,,(Σ@@@l) |- Σ₂,,Σ@l]
-| RLet : ∀ Γ Δ Σ₁ Σ₂ σ₁ σ₂ l, Rule ([Γ>Δ> Σ₂ |- [σ₂@@l]],,[Γ>Δ> Σ₁,,[σ₂@@l] |- [σ₁@@l] ]) [Γ>Δ> Σ₁,,Σ₂ |- [σ₁ @@l]]
+| RVoid : ∀ Γ Δ l, Rule [] [Γ > Δ > [] |- [] @l ]
-| RVoid : ∀ Γ Δ , Rule [] [Γ > Δ > [] |- [] ]
-
-| RAppT : forall Γ Δ Σ κ σ (τ:HaskType Γ κ) l, Rule [Γ>Δ> Σ |- [HaskTAll κ σ @@l]] [Γ>Δ> Σ |- [substT σ τ @@l]]
-| RAbsT : ∀ Γ Δ Σ κ σ l,
- Rule [(κ::Γ)> (weakCE Δ) > mapOptionTree weakLT Σ |- [ HaskTApp (weakF σ) (FreshHaskTyVar _) @@ (weakL l)]]
- [Γ>Δ > Σ |- [HaskTAll κ σ @@ l]]
+| RAppT : forall Γ Δ Σ κ σ (τ:HaskType Γ κ) l, Rule [Γ>Δ> Σ |- [HaskTAll κ σ]@l] [Γ>Δ> Σ |- [substT σ τ]@l]
+| RAbsT : ∀ Γ Δ Σ κ σ l n,
+ Rule [(list_ins n κ Γ)> (weakCE_ Δ) > mapOptionTree weakLT_ Σ |- [ HaskTApp (weakF_ σ) (FreshHaskTyVar_ _) ]@(weakL_ l)]
+ [Γ>Δ > Σ |- [HaskTAll κ σ ]@l]
| RAppCo : forall Γ Δ Σ κ (σ₁ σ₂:HaskType Γ κ) (γ:HaskCoercion Γ Δ (σ₁∼∼∼σ₂)) σ l,
- Rule [Γ>Δ> Σ |- [σ₁∼∼σ₂ ⇒ σ@@l]] [Γ>Δ> Σ |- [σ @@l]]
+ Rule [Γ>Δ> Σ |- [σ₁∼∼σ₂ ⇒ σ]@l] [Γ>Δ> Σ |- [σ ]@l]
| RAbsCo : forall Γ Δ Σ κ (σ₁ σ₂:HaskType Γ κ) σ l,
- Rule [Γ > ((σ₁∼∼∼σ₂)::Δ) > Σ |- [σ @@ l]]
- [Γ > Δ > Σ |- [σ₁∼∼σ₂⇒ σ @@l]]
+ Rule [Γ > ((σ₁∼∼∼σ₂)::Δ) > Σ |- [σ ]@l]
+ [Γ > Δ > Σ |- [σ₁∼∼σ₂⇒ σ ]@l]
-| RLetRec : forall Γ Δ Σ₁ τ₁ τ₂ lev, Rule [Γ > Δ > Σ₁,,(τ₂@@@lev) |- ([τ₁],,τ₂)@@@lev ] [Γ > Δ > Σ₁ |- [τ₁@@lev] ]
+| RLetRec : forall Γ Δ Σ₁ τ₁ τ₂ lev, Rule [Γ > Δ > (τ₂@@@lev),,Σ₁ |- (τ₂,,[τ₁]) @lev ] [Γ > Δ > Σ₁ |- [τ₁] @lev]
| RCase : forall Γ Δ lev tc Σ avars tbranches
- (alts:Tree ??{ sac : @StrongAltCon tc & @ProofCaseBranch tc Γ Δ lev tbranches avars sac }),
+ (alts:Tree ??( (@StrongAltCon tc) * (Tree ??(LeveledHaskType Γ ★)) )),
Rule
- ((mapOptionTree (fun x => pcb_judg (projT2 x)) alts),,
- [Γ > Δ > Σ |- [ caseType tc avars @@ lev ] ])
- [Γ > Δ > (mapOptionTreeAndFlatten (fun x => pcb_freevars (projT2 x)) alts),,Σ |- [ tbranches @@ lev ] ]
+ ((mapOptionTree (fun x => @pcb_judg tc Γ Δ lev tbranches avars (fst x) (snd x)) alts),,
+ [Γ > Δ > Σ |- [ caseType tc avars ] @lev])
+ [Γ > Δ > (mapOptionTreeAndFlatten (fun x => (snd x)) alts),,Σ |- [ tbranches ] @ lev]
.
+Definition RCut' : ∀ Γ Δ Σ₁ Σ₁₂ Σ₂ Σ₃ l,
+ ND Rule ([Γ>Δ> Σ₁ |- Σ₁₂ @l],,[Γ>Δ> (Σ₁₂@@@l),,Σ₂ |- Σ₃@l ]) [Γ>Δ> Σ₁,,Σ₂ |- Σ₃@l].
+ intros.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply ACanL ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RCut ].
+ apply nd_prod.
+ apply nd_id.
+ apply nd_rule.
+ apply RArrange.
+ apply AuCanL.
+ Defined.
+
+Definition RLet : ∀ Γ Δ Σ₁ Σ₂ σ₁ σ₂ l,
+ ND Rule ([Γ>Δ> Σ₁ |- [σ₁]@l],,[Γ>Δ> [σ₁@@l],,Σ₂ |- [σ₂]@l ]) [Γ>Δ> Σ₁,,Σ₂ |- [σ₂ ]@l].
+ intros.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RArrange; eapply ACanL ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RCut ].
+ apply nd_prod.
+ apply nd_id.
+ eapply nd_rule; eapply RArrange; eapply AuCanL.
+ Defined.
+
+Definition RWhere : ∀ Γ Δ Σ₁ Σ₂ Σ₃ σ₁ σ₂ l,
+ ND Rule ([Γ>Δ> Σ₁,,([σ₁@@l],,Σ₃) |- [σ₂]@l ],,[Γ>Δ> Σ₂ |- [σ₁]@l]) [Γ>Δ> Σ₁,,(Σ₂,,Σ₃) |- [σ₂ ]@l].
+ intros.
+ eapply nd_comp; [ apply nd_exch | idtac ].
+ eapply nd_rule; eapply RCut.
+ Defined.
(* A rule is considered "flat" if it is neither RBrak nor REsc *)
(* TODO: change this to (if RBrak/REsc -> False) *)
Inductive Rule_Flat : forall {h}{c}, Rule h c -> Prop :=
-| Flat_RArrange : ∀ Γ Δ h c r a , Rule_Flat (RArrange Γ Δ h c r a)
+| Flat_RArrange : ∀ Γ Δ h c r a l , Rule_Flat (RArrange Γ Δ h c r a l)
| Flat_RNote : ∀ Γ Δ Σ τ l n , Rule_Flat (RNote Γ Δ Σ τ l n)
| Flat_RLit : ∀ Γ Δ Σ τ , Rule_Flat (RLit Γ Δ Σ τ )
| Flat_RVar : ∀ Γ Δ σ l, Rule_Flat (RVar Γ Δ σ l)
| Flat_RLam : ∀ Γ Δ Σ tx te q , Rule_Flat (RLam Γ Δ Σ tx te q )
| Flat_RCast : ∀ Γ Δ Σ σ τ γ q , Rule_Flat (RCast Γ Δ Σ σ τ γ q )
-| Flat_RAbsT : ∀ Γ Σ κ σ a q , Rule_Flat (RAbsT Γ Σ κ σ a q )
+| Flat_RAbsT : ∀ Γ Σ κ σ a q n , Rule_Flat (RAbsT Γ Σ κ σ a q n)
| Flat_RAppT : ∀ Γ Δ Σ κ σ τ q , Rule_Flat (RAppT Γ Δ Σ κ σ τ q )
| Flat_RAppCo : ∀ Γ Δ Σ σ₁ σ₂ σ γ q l, Rule_Flat (RAppCo Γ Δ Σ σ₁ σ₂ σ γ q l)
| Flat_RAbsCo : ∀ Γ Σ κ σ σ₁ σ₂ q1 q2 , Rule_Flat (RAbsCo Γ Σ κ σ σ₁ σ₂ q1 q2 )
| Flat_RApp : ∀ Γ Δ Σ tx te p l, Rule_Flat (RApp Γ Δ Σ tx te p l)
-| Flat_RLet : ∀ Γ Δ Σ σ₁ σ₂ p l, Rule_Flat (RLet Γ Δ Σ σ₁ σ₂ p l)
-| Flat_RJoin : ∀ q a b c d e , Rule_Flat (RJoin q a b c d e)
-| Flat_RVoid : ∀ q a , Rule_Flat (RVoid q a)
+| Flat_RVoid : ∀ q a l, Rule_Flat (RVoid q a l)
| Flat_RCase : ∀ Σ Γ T κlen κ θ l x , Rule_Flat (RCase Σ Γ T κlen κ θ l x)
| Flat_RLetRec : ∀ Γ Δ Σ₁ τ₁ τ₂ lev, Rule_Flat (RLetRec Γ Δ Σ₁ τ₁ τ₂ lev).
destruct X0; destruct s; inversion e.
destruct X0; destruct s; inversion e.
destruct X0; destruct s; inversion e.
+ destruct X0; destruct s; inversion e.
Qed.
Lemma systemfc_all_rules_one_conclusion : forall h c1 c2 (r:Rule h (c1,,c2)), False.
auto.
Qed.
-
+++ /dev/null
-(*********************************************************************************************************************************)
-(* HaskProofFlattener: *)
-(* *)
-(* The Flattening Functor. *)
-(* *)
-(*********************************************************************************************************************************)
-
-Generalizable All Variables.
-Require Import Preamble.
-Require Import General.
-Require Import NaturalDeduction.
-Require Import Coq.Strings.String.
-Require Import Coq.Lists.List.
-
-Require Import HaskKinds.
-Require Import HaskCoreTypes.
-Require Import HaskLiteralsAndTyCons.
-Require Import HaskStrongTypes.
-Require Import HaskProof.
-Require Import NaturalDeduction.
-Require Import NaturalDeductionCategory.
-
-Require Import Algebras_ch4.
-Require Import Categories_ch1_3.
-Require Import Functors_ch1_4.
-Require Import Isomorphisms_ch1_5.
-Require Import ProductCategories_ch1_6_1.
-Require Import OppositeCategories_ch1_6_2.
-Require Import Enrichment_ch2_8.
-Require Import Subcategories_ch7_1.
-Require Import NaturalTransformations_ch7_4.
-Require Import NaturalIsomorphisms_ch7_5.
-Require Import BinoidalCategories.
-Require Import PreMonoidalCategories.
-Require Import MonoidalCategories_ch7_8.
-Require Import Coherence_ch7_8.
-
-Require Import HaskStrongTypes.
-Require Import HaskStrong.
-Require Import HaskProof.
-Require Import HaskStrongToProof.
-Require Import HaskProofToStrong.
-Require Import ProgrammingLanguage.
-Require Import HaskProofStratified.
-
-Open Scope nd_scope.
-
-
-(*
- * The flattening transformation. Currently only TWO-level languages are
- * supported, and the level-1 sublanguage is rather limited.
-*
- * This file abuses terminology pretty badly. For purposes of this file,
- * "PCF" means "the level-1 sublanguage" and "FC" (aka System FC) means
- * the whole language (level-0 language including bracketed level-1 terms)
- *)
-Section HaskProofFlattener.
-
-
-(*
- Definition code2garrow0 {Γ}(ec t1 t2:RawHaskType Γ ★) : RawHaskType Γ ★.
- admit.
- Defined.
- Definition code2garrow Γ (ec t:RawHaskType Γ ★) :=
- match t with
-(* | TApp ★ ★ (TApp _ ★ TArrow tx) t' => code2garrow0 ec tx t'*)
- | _ => code2garrow0 ec unitType t
- end.
- Opaque code2garrow.
- Fixpoint typeMap {TV}{κ}(ty:@RawHaskType TV κ) : @RawHaskType TV κ :=
- match ty as TY in RawHaskType _ K return RawHaskType TV K with
- | TCode ec t => code2garrow _ ec t
- | TApp _ _ t1 t2 => TApp (typeMap t1) (typeMap t2)
- | TAll _ f => TAll _ (fun tv => typeMap (f tv))
- | TCoerc _ t1 t2 t3 => TCoerc (typeMap t1) (typeMap t2) (typeMap t3)
- | TVar _ v => TVar v
- | TArrow => TArrow
- | TCon tc => TCon tc
- | TyFunApp tf rhtl => (* FIXME *) TyFunApp tf rhtl
- end.
-*)
-
-
-(*
- Definition code2garrow Γ (ec t:RawHaskType Γ ★) :=
- match t with
-(* | TApp ★ ★ (TApp _ ★ TArrow tx) t' => code2garrow0 ec tx t'*)
- | _ => code2garrow0 ec unitType t
- end.
- Opaque code2garrow.
- Fixpoint typeMap {TV}{κ}(ty:@RawHaskType TV κ) : @RawHaskType TV κ :=
- match ty as TY in RawHaskType _ K return RawHaskType TV K with
- | TCode ec t => code2garrow _ ec t
- | TApp _ _ t1 t2 => TApp (typeMap t1) (typeMap t2)
- | TAll _ f => TAll _ (fun tv => typeMap (f tv))
- | TCoerc _ t1 t2 t3 => TCoerc (typeMap t1) (typeMap t2) (typeMap t3)
- | TVar _ v => TVar v
- | TArrow => TArrow
- | TCon tc => TCon tc
- | TyFunApp tf rhtl => (* FIXME *) TyFunApp tf rhtl
- end.
-
- Definition typeMapL {Γ}(lht:LeveledHaskType Γ ★) : LeveledHaskType Γ ★ :=
- match lht with
-(* | t @@ nil => (fun TV ite => typeMap (t TV ite)) @@ lev*)
- | t @@ lev => (fun TV ite => typeMap (t TV ite)) @@ lev
- end.
-*)
-
- (* gathers a tree of guest-language types into a single host-language types via the tensor *)
- Definition tensorizeType {Γ} (lt:Tree ??(HaskType Γ ★)) : HaskType Γ ★.
- admit.
- Defined.
-
- Definition mkGA {Γ} : HaskType Γ ★ -> HaskType Γ ★ -> HaskType Γ ★.
- admit.
- Defined.
-
- Definition guestJudgmentAsGArrowType {Γ}{Δ}(lt:PCFJudg Γ Δ) : HaskType Γ ★ :=
- match lt with
- (x,y) => (mkGA (tensorizeType x) (tensorizeType y))
- end.
-
- Definition obact {Γ}{Δ} (X:Tree ??(PCFJudg Γ Δ)) : Tree ??(LeveledHaskType Γ ★) :=
- mapOptionTree guestJudgmentAsGArrowType X @@@ nil.
-
- Hint Constructors Rule_Flat.
- Context {ndr:@ND_Relation _ Rule}.
-
- (*
- * Here it is, what you've all been waiting for! When reading this,
- * it might help to have the definition for "Inductive ND" (see
- * NaturalDeduction.v) handy as a cross-reference.
- *)
- Hint Constructors Rule_Flat.
- Definition FlatteningFunctor_fmor {Γ}{Δ}{ec}
- : forall h c,
- (h~~{JudgmentsL (PCF Γ Δ ec)}~~>c) ->
- ((obact(Δ:=ec) h)~~{TypesL (SystemFCa Γ Δ)}~~>(obact(Δ:=ec) c)).
-
- set (@nil (HaskTyVar Γ ★)) as lev.
-
- unfold hom; unfold ob; unfold ehom; simpl; unfold pmon_I; unfold obact; intros.
-
- induction X; simpl.
-
- (* the proof from no hypotheses of no conclusions (nd_id0) becomes RVoid *)
- apply nd_rule; apply (org_fc _ _ [] [(_,_)] (RVoid _ _)). apply Flat_RVoid.
-
- (* the proof from hypothesis X of conclusion X (nd_id1) becomes RVar *)
- apply nd_rule; apply (org_fc _ _ [] [(_,_)] (RVar _ _ _ _)). apply Flat_RVar.
-
- (* the proof from hypothesis X of no conclusions (nd_weak) becomes RWeak;;RVoid *)
- eapply nd_comp;
- [ idtac
- | eapply nd_rule
- ; eapply (org_fc _ _ [(_,_)] [(_,_)] (RArrange _ _ _ _ _ (RWeak _)))
- ; auto ].
- eapply nd_rule.
- eapply (org_fc _ _ [] [(_,_)] (RVoid _ _)); auto. apply Flat_RVoid.
- apply Flat_RArrange.
-
- (* the proof from hypothesis X of two identical conclusions X,,X (nd_copy) becomes RVar;;RJoin;;RCont *)
- eapply nd_comp; [ idtac | eapply nd_rule; eapply (org_fc _ _ [(_,_)] [(_,_)] (RArrange _ _ _ _ _ (RCont _))) ].
- eapply nd_comp; [ apply nd_llecnac | idtac ].
- set (snd_initial(SequentND:=pl_snd(ProgrammingLanguage:=SystemFCa Γ Δ))
- (mapOptionTree (guestJudgmentAsGArrowType(Δ:=ec)) h @@@ lev)) as q.
- eapply nd_comp.
- eapply nd_prod.
- apply q.
- apply q.
- apply nd_rule.
- eapply (org_fc _ _ ([(_,_)],,[(_,_)]) [(_,_)] (RJoin _ _ _ _ _ _ )).
- destruct h; simpl.
- destruct o.
- simpl.
- apply Flat_RJoin.
- apply Flat_RJoin.
- apply Flat_RJoin.
- apply Flat_RArrange.
-
- (* nd_prod becomes nd_llecnac;;nd_prod;;RJoin *)
- eapply nd_comp.
- apply (nd_llecnac ;; nd_prod IHX1 IHX2).
- apply nd_rule.
- eapply (org_fc _ _ ([(_,_)],,[(_,_)]) [(_,_)] (RJoin _ _ _ _ _ _ )).
- apply (Flat_RJoin Γ Δ (mapOptionTree guestJudgmentAsGArrowType h1 @@@ nil)
- (mapOptionTree guestJudgmentAsGArrowType h2 @@@ nil)
- (mapOptionTree guestJudgmentAsGArrowType c1 @@@ nil)
- (mapOptionTree guestJudgmentAsGArrowType c2 @@@ nil)).
-
- (* nd_comp becomes pl_subst (aka nd_cut) *)
- eapply nd_comp.
- apply (nd_llecnac ;; nd_prod IHX1 IHX2).
- clear IHX1 IHX2 X1 X2.
- (*
- apply (@snd_cut _ _ _ _ _ _ (@pl_cnd _ _ _ _ (SystemFCa Γ Δ))).
- *)
- admit.
-
- (* nd_cancell becomes RVar;;RuCanL *)
- eapply nd_comp;
- [ idtac | eapply nd_rule; apply (org_fc _ _ [(_,_)] [(_,_)] (RArrange _ _ _ _ _ (RuCanL _))) ].
- apply (snd_initial(SequentND:=pl_cnd(ProgrammingLanguage:=(SystemFCa Γ Δ)))).
- apply Flat_RArrange.
-
- (* nd_cancelr becomes RVar;;RuCanR *)
- eapply nd_comp;
- [ idtac | eapply nd_rule; apply (org_fc _ _ [(_,_)] [(_,_)] (RArrange _ _ _ _ _ (RuCanR _))) ].
- apply (snd_initial(SequentND:=pl_cnd(ProgrammingLanguage:=(SystemFCa Γ Δ)))).
- apply Flat_RArrange.
-
- (* nd_llecnac becomes RVar;;RCanL *)
- eapply nd_comp;
- [ idtac | eapply nd_rule; apply (org_fc _ _ [(_,_)] [(_,_)] (RArrange _ _ _ _ _ (RCanL _))) ].
- apply (snd_initial(SequentND:=pl_cnd(ProgrammingLanguage:=(SystemFCa Γ Δ)))).
- apply Flat_RArrange.
-
- (* nd_rlecnac becomes RVar;;RCanR *)
- eapply nd_comp;
- [ idtac | eapply nd_rule; apply (org_fc _ _ [(_,_)] [(_,_)] (RArrange _ _ _ _ _ (RCanR _))) ].
- apply (snd_initial(SequentND:=pl_cnd(ProgrammingLanguage:=(SystemFCa Γ Δ)))).
- apply Flat_RArrange.
-
- (* nd_assoc becomes RVar;;RAssoc *)
- eapply nd_comp;
- [ idtac | eapply nd_rule; apply (org_fc _ _ [(_,_)] [(_,_)] (RArrange _ _ _ _ _ (RAssoc _ _ _))) ].
- apply (snd_initial(SequentND:=pl_cnd(ProgrammingLanguage:=(SystemFCa Γ Δ)))).
- apply Flat_RArrange.
-
- (* nd_cossa becomes RVar;;RCossa *)
- eapply nd_comp;
- [ idtac | eapply nd_rule; apply (org_fc _ _ [(_,_)] [(_,_)] (RArrange _ _ _ _ _ (RCossa _ _ _))) ].
- apply (snd_initial(SequentND:=pl_cnd(ProgrammingLanguage:=(SystemFCa Γ Δ)))).
- apply Flat_RArrange.
-
- destruct r as [r rp].
- refine (match rp as R in @Rule_PCF _ _ _ H C _ with
- | PCF_RArrange h c r q => let case_RURule := tt in _
- | PCF_RLit lit => let case_RLit := tt in _
- | PCF_RNote Σ τ n => let case_RNote := tt in _
- | PCF_RVar σ => let case_RVar := tt in _
- | PCF_RLam Σ tx te => let case_RLam := tt in _
- | PCF_RApp Σ tx te p => let case_RApp := tt in _
- | PCF_RLet Σ σ₁ σ₂ p => let case_RLet := tt in _
- | PCF_RJoin b c d e => let case_RJoin := tt in _
- | PCF_RVoid => let case_RVoid := tt in _
- (*| PCF_RCase T κlen κ θ l x => let case_RCase := tt in _*)
- (*| PCF_RLetRec Σ₁ τ₁ τ₂ lev => let case_RLetRec := tt in _*)
- end); simpl in *.
- clear rp.
- clear r h c.
- rename r0 into r; rename h0 into h; rename c0 into c.
-
- destruct case_RURule.
- refine (match q with
- | RLeft a b c r => let case_RLeft := tt in _
- | RRight a b c r => let case_RRight := tt in _
- | RCanL b => let case_RCanL := tt in _
- | RCanR b => let case_RCanR := tt in _
- | RuCanL b => let case_RuCanL := tt in _
- | RuCanR b => let case_RuCanR := tt in _
- | RAssoc b c d => let case_RAssoc := tt in _
- | RCossa b c d => let case_RCossa := tt in _
- | RExch b c => let case_RExch := tt in _
- | RWeak b => let case_RWeak := tt in _
- | RCont b => let case_RCont := tt in _
- | RComp a b c f g => let case_RComp := tt in _
- end).
-
- destruct case_RCanL.
- (* ga_cancell *)
- admit.
-
- destruct case_RCanR.
- (* ga_cancelr *)
- admit.
-
- destruct case_RuCanL.
- (* ga_uncancell *)
- admit.
-
- destruct case_RuCanR.
- (* ga_uncancelr *)
- admit.
-
- destruct case_RAssoc.
- (* ga_assoc *)
- admit.
-
- destruct case_RCossa.
- (* ga_unassoc *)
- admit.
-
- destruct case_RExch.
- (* ga_swap *)
- admit.
-
- destruct case_RWeak.
- (* ga_drop *)
- admit.
-
- destruct case_RCont.
- (* ga_copy *)
- admit.
-
- destruct case_RLeft.
- (* ga_second *)
- admit.
-
- destruct case_RRight.
- (* ga_first *)
- admit.
-
- destruct case_RComp.
- (* ga_comp *)
- admit.
-
- destruct case_RLit.
- (* ga_literal *)
- admit.
-
- (* hey cool, I figured out how to pass CoreNote's through... *)
- destruct case_RNote.
- eapply nd_comp.
- eapply nd_rule.
- eapply (org_fc _ _ [] [(_,_)] (RVar _ _ _ _)) . auto.
- apply Flat_RVar.
- apply nd_rule.
- apply (org_fc _ _ [(_,_)] [(_,_)] (RNote _ _ _ _ _ n)). auto.
- apply Flat_RNote.
-
- destruct case_RVar.
- (* ga_id *)
- admit.
-
- destruct case_RLam.
- (* ga_curry, but try to avoid this someday in the future if the argument type isn't a function *)
- admit.
-
- destruct case_RApp.
- (* ga_apply *)
- admit.
-
- destruct case_RLet.
- (* ga_comp! perhaps this means the ga_curry avoidance can be done by turning lambdas into lets? *)
- admit.
-
- destruct case_RVoid.
- (* ga_id u *)
- admit.
-
- destruct case_RJoin.
- (* ga_first+ga_second; technically this assumes a specific evaluation order, which is bad *)
- admit.
-
- Defined.
-
- Instance FlatteningFunctor {Γ}{Δ}{ec} : Functor (JudgmentsL (PCF Γ Δ ec)) (TypesL (SystemFCa Γ Δ)) (obact) :=
- { fmor := FlatteningFunctor_fmor }.
- admit.
- admit.
- admit.
- Defined.
-
- (*
- Definition ReificationFunctor Γ Δ : Functor (JudgmentsL _ _ (PCF n Γ Δ)) SystemFCa' (mapOptionTree brakifyJudg).
- refine {| fmor := ReificationFunctor_fmor Γ Δ |}; unfold hom; unfold ob; simpl ; intros.
- unfold ReificationFunctor_fmor; simpl.
- admit.
- unfold ReificationFunctor_fmor; simpl.
- admit.
- unfold ReificationFunctor_fmor; simpl.
- admit.
- Defined.
-
- Definition PCF_SMME (n:nat)(Γ:TypeEnv)(Δ:CoercionEnv Γ) : ProgrammingLanguageSMME.
- refine {| plsmme_pl := PCF n Γ Δ |}.
- admit.
- Defined.
-
- Definition SystemFCa_SMME (n:nat)(Γ:TypeEnv)(Δ:CoercionEnv Γ) : ProgrammingLanguageSMME.
- refine {| plsmme_pl := SystemFCa n Γ Δ |}.
- admit.
- Defined.
-
- Definition ReificationFunctorMonoidal n : MonoidalFunctor (JudgmentsN n) (JudgmentsN (S n)) (ReificationFunctor n).
- admit.
- Defined.
-
- (* 5.1.4 *)
- Definition PCF_SystemFCa_two_level n Γ Δ : TwoLevelLanguage (PCF_SMME n Γ Δ) (SystemFCa_SMME (S n) Γ Δ).
- admit.
- (* ... and the retraction exists *)
- Defined.
- *)
- (* Any particular proof in HaskProof is only finitely large, so it uses only finitely many levels of nesting, so
- * it falls within (SystemFCa n) for some n. This function calculates that "n" and performs the translation *)
- (*
- Definition HaskProof_to_SystemFCa :
- forall h c (pf:ND Rule h c),
- { n:nat & h ~~{JudgmentsL (SystemFCa_SMME n)}~~> c }.
- *)
- (* for every n we have a functor from the category of (n+1)-bounded proofs to the category of n-bounded proofs *)
-
-End HaskProofFlattener.
-
+++ /dev/null
-(*********************************************************************************************************************************)
-(* HaskProofStratified: *)
-(* *)
-(* An alternate representation for HaskProof which ensures that deductions on a given level are grouped into contiguous *)
-(* blocks. This representation lacks the attractive compositionality properties of HaskProof, but makes it easier to *)
-(* perform the flattening process. *)
-(* *)
-(*********************************************************************************************************************************)
-
-Generalizable All Variables.
-Require Import Preamble.
-Require Import General.
-Require Import NaturalDeduction.
-Require Import Coq.Strings.String.
-Require Import Coq.Lists.List.
-
-Require Import HaskKinds.
-Require Import HaskCoreTypes.
-Require Import HaskLiteralsAndTyCons.
-Require Import HaskStrongTypes.
-Require Import HaskProof.
-Require Import NaturalDeduction.
-Require Import NaturalDeductionCategory.
-
-Require Import Algebras_ch4.
-Require Import Categories_ch1_3.
-Require Import Functors_ch1_4.
-Require Import Isomorphisms_ch1_5.
-Require Import ProductCategories_ch1_6_1.
-Require Import OppositeCategories_ch1_6_2.
-Require Import Enrichment_ch2_8.
-Require Import Subcategories_ch7_1.
-Require Import NaturalTransformations_ch7_4.
-Require Import NaturalIsomorphisms_ch7_5.
-Require Import MonoidalCategories_ch7_8.
-Require Import Coherence_ch7_8.
-
-Require Import HaskStrongTypes.
-Require Import HaskStrong.
-Require Import HaskProof.
-Require Import HaskStrongToProof.
-Require Import HaskProofToStrong.
-Require Import ProgrammingLanguage.
-
-Open Scope nd_scope.
-
-
-(*
- * The flattening transformation. Currently only TWO-level languages are
- * supported, and the level-1 sublanguage is rather limited.
-*
- * This file abuses terminology pretty badly. For purposes of this file,
- * "PCF" means "the level-1 sublanguage" and "FC" (aka System FC) means
- * the whole language (level-0 language including bracketed level-1 terms)
- *)
-Section HaskProofStratified.
-
- Section PCF.
-
- Context (ndr_systemfc:@ND_Relation _ Rule).
-
- Context Γ (Δ:CoercionEnv Γ).
- Definition PCFJudg (ec:HaskTyVar Γ ★) :=
- @prod (Tree ??(HaskType Γ ★)) (Tree ??(HaskType Γ ★)).
- Definition pcfjudg (ec:HaskTyVar Γ ★) :=
- @pair (Tree ??(HaskType Γ ★)) (Tree ??(HaskType Γ ★)).
-
- (* given an PCFJudg at depth (ec::depth) we can turn it into an PCFJudg
- * from depth (depth) by wrapping brackets around everything in the
- * succedent and repopulating *)
- Definition brakify {ec} (j:PCFJudg ec) : Judg :=
- match j with
- (Σ,τ) => Γ > Δ > (Σ@@@(ec::nil)) |- (mapOptionTree (fun t => HaskBrak ec t) τ @@@ nil)
- end.
-
- Definition pcf_vars {Γ}(ec:HaskTyVar Γ ★)(t:Tree ??(LeveledHaskType Γ ★)) : Tree ??(HaskType Γ ★)
- := mapOptionTreeAndFlatten (fun lt =>
- match lt with t @@ l => match l with
- | ec'::nil => if eqd_dec ec ec' then [t] else []
- | _ => []
- end
- end) t.
-
- Inductive MatchingJudgments {ec} : Tree ??(PCFJudg ec) -> Tree ??Judg -> Type :=
- | match_nil : MatchingJudgments [] []
- | match_branch : forall a b c d, MatchingJudgments a b -> MatchingJudgments c d -> MatchingJudgments (a,,c) (b,,d)
- | match_leaf :
- forall Σ τ lev,
- MatchingJudgments
- [((pcf_vars ec Σ) , τ )]
- [Γ > Δ > Σ |- (mapOptionTree (HaskBrak ec) τ @@@ lev)].
-
- Definition fc_vars {Γ}(ec:HaskTyVar Γ ★)(t:Tree ??(LeveledHaskType Γ ★)) : Tree ??(HaskType Γ ★)
- := mapOptionTreeAndFlatten (fun lt =>
- match lt with t @@ l => match l with
- | ec'::nil => if eqd_dec ec ec' then [] else [t]
- | _ => []
- end
- end) t.
-
- Definition pcfjudg2judg ec (cj:PCFJudg ec) :=
- match cj with (Σ,τ) => Γ > Δ > (Σ @@@ (ec::nil)) |- (τ @@@ (ec::nil)) end.
-
- (* Rules allowed in PCF; i.e. rules we know how to turn into GArrows *)
- (* Rule_PCF consists of the rules allowed in flat PCF: everything except *)
- (* AppT, AbsT, AppC, AbsC, Cast, Global, and some Case statements *)
- Inductive Rule_PCF (ec:HaskTyVar Γ ★)
- : forall (h c:Tree ??(PCFJudg ec)), Rule (mapOptionTree (pcfjudg2judg ec) h) (mapOptionTree (pcfjudg2judg ec) c) -> Type :=
- | PCF_RArrange : ∀ x y t a, Rule_PCF ec [(_, _)] [(_, _)] (RArrange Γ Δ (x@@@(ec::nil)) (y@@@(ec::nil)) (t@@@(ec::nil)) a)
- | PCF_RLit : ∀ lit , Rule_PCF ec [ ] [ ([],[_]) ] (RLit Γ Δ lit (ec::nil))
- | PCF_RNote : ∀ Σ τ n , Rule_PCF ec [(_,[_])] [(_,[_])] (RNote Γ Δ (Σ@@@(ec::nil)) τ (ec::nil) n)
- | PCF_RVar : ∀ σ , Rule_PCF ec [ ] [([_],[_])] (RVar Γ Δ σ (ec::nil) )
- | PCF_RLam : ∀ Σ tx te , Rule_PCF ec [((_,,[_]),[_])] [(_,[_])] (RLam Γ Δ (Σ@@@(ec::nil)) tx te (ec::nil) )
-
- | PCF_RApp : ∀ Σ Σ' tx te ,
- Rule_PCF ec ([(_,[_])],,[(_,[_])]) [((_,,_),[_])]
- (RApp Γ Δ (Σ@@@(ec::nil))(Σ'@@@(ec::nil)) tx te (ec::nil))
-
- | PCF_RLet : ∀ Σ Σ' σ₂ p,
- Rule_PCF ec ([(_,[_])],,[((_,,[_]),[_])]) [((_,,_),[_])]
- (RLet Γ Δ (Σ@@@(ec::nil)) (Σ'@@@(ec::nil)) σ₂ p (ec::nil))
-
- | PCF_RVoid : Rule_PCF ec [ ] [([],[])] (RVoid Γ Δ )
-(*| PCF_RLetRec : ∀ Σ₁ τ₁ τ₂ , Rule_PCF (ec::nil) _ _ (RLetRec Γ Δ Σ₁ τ₁ τ₂ (ec::nil) )*)
- | PCF_RJoin : ∀ Σ₁ Σ₂ τ₁ τ₂, Rule_PCF ec ([(_,_)],,[(_,_)]) [((_,,_),(_,,_))]
- (RJoin Γ Δ (Σ₁@@@(ec::nil)) (Σ₂@@@(ec::nil)) (τ₁@@@(ec::nil)) (τ₂@@@(ec::nil))).
- (* need int/boolean case *)
- Implicit Arguments Rule_PCF [ ].
-
- Definition PCFRule lev h c := { r:_ & @Rule_PCF lev h c r }.
- End PCF.
-
- Definition FCJudg Γ (Δ:CoercionEnv Γ) :=
- @prod (Tree ??(LeveledHaskType Γ ★)) (Tree ??(LeveledHaskType Γ ★)).
- Definition fcjudg2judg {Γ}{Δ}(fc:FCJudg Γ Δ) :=
- match fc with
- (x,y) => Γ > Δ > x |- y
- end.
- Coercion fcjudg2judg : FCJudg >-> Judg.
-
- Definition pcfjudg2fcjudg {Γ}{Δ} ec (fc:PCFJudg Γ ec) : FCJudg Γ Δ :=
- match fc with
- (x,y) => (x @@@ (ec::nil),y @@@ (ec::nil))
- end.
-
- (* An organized deduction has been reorganized into contiguous blocks whose
- * hypotheses (if any) and conclusion have the same Γ and Δ and a fixed nesting depth. The boolean
- * indicates if non-PCF rules have been used *)
- Inductive OrgR Γ Δ : Tree ??(FCJudg Γ Δ) -> Tree ??(FCJudg Γ Δ) -> Type :=
-
- | org_fc : forall (h c:Tree ??(FCJudg Γ Δ))
- (r:Rule (mapOptionTree fcjudg2judg h) (mapOptionTree fcjudg2judg c)),
- Rule_Flat r ->
- OrgR _ _ h c
-
- | org_pcf : forall ec h c,
- ND (PCFRule Γ Δ ec) h c ->
- OrgR Γ Δ (mapOptionTree (pcfjudg2fcjudg ec) h) (mapOptionTree (pcfjudg2fcjudg ec) c).
-
- Definition mkEsc Γ Δ ec (h:Tree ??(PCFJudg Γ ec))
- : ND Rule
- (mapOptionTree (brakify Γ Δ) h)
- (mapOptionTree (pcfjudg2judg Γ Δ ec) h).
- apply nd_replicate; intros.
- destruct o; simpl in *.
- induction t0.
- destruct a; simpl.
- apply nd_rule.
- apply REsc.
- apply nd_id.
- apply (Prelude_error "mkEsc got multi-leaf succedent").
- Defined.
-
- Definition mkBrak Γ Δ ec (h:Tree ??(PCFJudg Γ ec))
- : ND Rule
- (mapOptionTree (pcfjudg2judg Γ Δ ec) h)
- (mapOptionTree (brakify Γ Δ) h).
- apply nd_replicate; intros.
- destruct o; simpl in *.
- induction t0.
- destruct a; simpl.
- apply nd_rule.
- apply RBrak.
- apply nd_id.
- apply (Prelude_error "mkBrak got multi-leaf succedent").
- Defined.
-
- (*
- Definition Partition {Γ} ec (Σ:Tree ??(LeveledHaskType Γ ★)) :=
- { vars:(_ * _) |
- fc_vars ec Σ = fst vars /\
- pcf_vars ec Σ = snd vars }.
- *)
-
- Definition pcfToND Γ Δ : forall ec h c,
- ND (PCFRule Γ Δ ec) h c -> ND Rule (mapOptionTree (pcfjudg2judg Γ Δ ec) h) (mapOptionTree (pcfjudg2judg Γ Δ ec) c).
- intros.
- eapply (fun q => nd_map' _ q X).
- intros.
- destruct X0.
- apply nd_rule.
- apply x.
- Defined.
-
- Instance OrgPCF Γ Δ lev : @ND_Relation _ (PCFRule Γ Δ lev) :=
- { ndr_eqv := fun a b f g => (pcfToND _ _ _ _ _ f) === (pcfToND _ _ _ _ _ g) }.
- Admitted.
-
- (*
- * An intermediate representation necessitated by Coq's termination
- * conditions. This is basically a tree where each node is a
- * subproof which is either entirely level-1 or entirely level-0
- *)
- Inductive Alternating : Tree ??Judg -> Type :=
-
- | alt_nil : Alternating []
-
- | alt_branch : forall a b,
- Alternating a -> Alternating b -> Alternating (a,,b)
-
- | alt_fc : forall h c,
- Alternating h ->
- ND Rule h c ->
- Alternating c
-
- | alt_pcf : forall Γ Δ ec h c h' c',
- MatchingJudgments Γ Δ h h' ->
- MatchingJudgments Γ Δ c c' ->
- Alternating h' ->
- ND (PCFRule Γ Δ ec) h c ->
- Alternating c'.
-
- Require Import Coq.Logic.Eqdep.
-
- Lemma magic a b c d ec e :
- ClosedSIND(Rule:=Rule) [a > b > c |- [d @@ (ec :: e)]] ->
- ClosedSIND(Rule:=Rule) [a > b > pcf_vars ec c @@@ (ec :: nil) |- [d @@ (ec :: nil)]].
- admit.
- Defined.
-
- Definition orgify : forall Γ Δ Σ τ (pf:ClosedSIND(Rule:=Rule) [Γ > Δ > Σ |- τ]), Alternating [Γ > Δ > Σ |- τ].
-
- refine (
- fix orgify_fc' Γ Δ Σ τ (pf:ClosedSIND [Γ > Δ > Σ |- τ]) {struct pf} : Alternating [Γ > Δ > Σ |- τ] :=
- let case_main := tt in _
- with orgify_fc c (pf:ClosedSIND c) {struct pf} : Alternating c :=
- (match c as C return C=c -> Alternating C with
- | T_Leaf None => fun _ => alt_nil
- | T_Leaf (Some (Γ > Δ > Σ |- τ)) => let case_leaf := tt in fun eqpf => _
- | T_Branch b1 b2 => let case_branch := tt in fun eqpf => _
- end (refl_equal _))
- with orgify_pcf Γ Δ ec pcfj j (m:MatchingJudgments Γ Δ pcfj j)
- (pf:ClosedSIND (mapOptionTree (pcfjudg2judg Γ Δ ec) pcfj)) {struct pf} : Alternating j :=
- let case_pcf := tt in _
- for orgify_fc').
-
- destruct case_main.
- inversion pf; subst.
- set (alt_fc _ _ (orgify_fc _ X) (nd_rule X0)) as backup.
- refine (match X0 as R in Rule H C return
- match C with
- | T_Leaf (Some (Γ > Δ > Σ |- τ)) =>
- h=H -> Alternating [Γ > Δ > Σ |- τ] -> Alternating [Γ > Δ > Σ |- τ]
- | _ => True
- end
- with
- | RBrak Σ a b c n m => let case_RBrak := tt in fun pf' backup => _
- | REsc Σ a b c n m => let case_REsc := tt in fun pf' backup => _
- | _ => fun pf' x => x
- end (refl_equal _) backup).
- clear backup0 backup.
-
- destruct case_RBrak.
- rename c into ec.
- set (@match_leaf Σ0 a ec n [b] m) as q.
- set (orgify_pcf Σ0 a ec _ _ q) as q'.
- apply q'.
- simpl.
- rewrite pf' in X.
- apply magic in X.
- apply X.
-
- destruct case_REsc.
- apply (Prelude_error "encountered Esc in wrong side of mkalt").
-
- destruct case_leaf.
- apply orgify_fc'.
- rewrite eqpf.
- apply pf.
-
- destruct case_branch.
- rewrite <- eqpf in pf.
- inversion pf; subst.
- apply no_rules_with_multiple_conclusions in X0.
- inversion X0.
- exists b1. exists b2.
- auto.
- apply (alt_branch _ _ (orgify_fc _ X) (orgify_fc _ X0)).
-
- destruct case_pcf.
- Admitted.
-
- Definition pcfify Γ Δ ec : forall Σ τ,
- ClosedSIND(Rule:=Rule) [ Γ > Δ > Σ@@@(ec::nil) |- τ @@@ (ec::nil)]
- -> ND (PCFRule Γ Δ ec) [] [(Σ,τ)].
-
- refine ((
- fix pcfify Σ τ (pn:@ClosedSIND _ Rule [ Γ > Δ > Σ@@@(ec::nil) |- τ @@@ (ec::nil)]) {struct pn}
- : ND (PCFRule Γ Δ ec) [] [(Σ,τ)] :=
- (match pn in @ClosedSIND _ _ J return J=[Γ > Δ > Σ@@@(ec::nil) |- τ @@@ (ec::nil)] -> _ with
- | cnd_weak => let case_nil := tt in _
- | cnd_rule h c cnd' r => let case_rule := tt in _
- | cnd_branch _ _ c1 c2 => let case_branch := tt in _
- end (refl_equal _)))).
- intros.
- inversion H.
- intros.
- destruct c; try destruct o; inversion H.
- destruct j.
- Admitted.
-
- (* any proof in organized form can be "dis-organized" *)
- (*
- Definition unOrgR : forall Γ Δ h c, OrgR Γ Δ h c -> ND Rule h c.
- intros.
- induction X.
- apply nd_rule.
- apply r.
- eapply nd_comp.
- (*
- apply (mkEsc h).
- eapply nd_comp; [ idtac | apply (mkBrak c) ].
- apply pcfToND.
- apply n.
- *)
- Admitted.
- Definition unOrgND Γ Δ h c : ND (OrgR Γ Δ) h c -> ND Rule h c := nd_map (unOrgR Γ Δ).
- *)
-
- Hint Constructors Rule_Flat.
-
- Definition PCF_Arrange {Γ}{Δ}{lev} : forall x y z, Arrange x y -> ND (PCFRule Γ Δ lev) [(x,z)] [(y,z)].
- admit.
- Defined.
-
- Definition PCF_cut Γ Δ lev : forall a b c, ND (PCFRule Γ Δ lev) ([(a,b)],,[(b,c)]) [(a,c)].
- intros.
- destruct b.
- destruct o.
- destruct c.
- destruct o.
-
- (* when the cut is a single leaf and the RHS is a single leaf: *)
- eapply nd_comp.
- eapply nd_prod.
- apply nd_id.
- apply (PCF_Arrange [h] ([],,[h]) [h0]).
- apply RuCanL.
- eapply nd_comp; [ idtac | apply (PCF_Arrange ([],,a) a [h0]); apply RCanL ].
- apply nd_rule.
- (*
- set (@RLet Γ Δ [] (a@@@(ec::nil)) h0 h (ec::nil)) as q.
- exists q.
- apply (PCF_RLet _ [] a h0 h).
- apply (Prelude_error "cut rule invoked with [a|=[b]] [[b]|=[]]").
- apply (Prelude_error "cut rule invoked with [a|=[b]] [[b]|=[x,,y]]").
- apply (Prelude_error "cut rule invoked with [a|=[]] [[]|=c]").
- apply (Prelude_error "cut rule invoked with [a|=[b,,c]] [[b,,c]|=z]").
- *)
- Admitted.
-
- Instance PCF_sequents Γ Δ lev ec : @SequentND _ (PCFRule Γ Δ lev) _ (pcfjudg Γ ec) :=
- { snd_cut := PCF_cut Γ Δ lev }.
- apply Build_SequentND.
- intros.
- induction a.
- destruct a; simpl.
- apply nd_rule.
- exists (RVar _ _ _ _).
- apply PCF_RVar.
- apply nd_rule.
- exists (RVoid _ _ ).
- apply PCF_RVoid.
- eapply nd_comp.
- eapply nd_comp; [ apply nd_llecnac | idtac ].
- apply (nd_prod IHa1 IHa2).
- apply nd_rule.
- exists (RJoin _ _ _ _ _ _).
- apply PCF_RJoin.
- admit.
- Defined.
-
- Definition PCF_left Γ Δ lev a b c : ND (PCFRule Γ Δ lev) [(b,c)] [((a,,b),(a,,c))].
- eapply nd_comp; [ apply nd_llecnac | eapply nd_comp; [ idtac | idtac ] ].
- eapply nd_prod; [ apply snd_initial | apply nd_id ].
- apply nd_rule.
- set (@PCF_RJoin Γ Δ lev a b a c) as q'.
- refine (existT _ _ _).
- apply q'.
- Admitted.
-
- Definition PCF_right Γ Δ lev a b c : ND (PCFRule Γ Δ lev) [(b,c)] [((b,,a),(c,,a))].
- eapply nd_comp; [ apply nd_rlecnac | eapply nd_comp; [ idtac | idtac ] ].
- eapply nd_prod; [ apply nd_id | apply snd_initial ].
- apply nd_rule.
- set (@PCF_RJoin Γ Δ lev b a c a) as q'.
- refine (existT _ _ _).
- apply q'.
- Admitted.
-
- Instance PCF_sequent_join Γ Δ lev : @ContextND _ (PCFRule Γ Δ lev) _ (pcfjudg Γ lev) _ :=
- { cnd_expand_left := fun a b c => PCF_left Γ Δ lev c a b
- ; cnd_expand_right := fun a b c => PCF_right Γ Δ lev c a b }.
-
- intros; apply nd_rule. unfold PCFRule. simpl.
- exists (RArrange _ _ _ _ _ (RCossa _ _ _)).
- apply (PCF_RArrange _ _ lev ((a,,b),,c) (a,,(b,,c)) x).
-
- intros; apply nd_rule. unfold PCFRule. simpl.
- exists (RArrange _ _ _ _ _ (RAssoc _ _ _)).
- apply (PCF_RArrange _ _ lev (a,,(b,,c)) ((a,,b),,c) x).
-
- intros; apply nd_rule. unfold PCFRule. simpl.
- exists (RArrange _ _ _ _ _ (RCanL _)).
- apply (PCF_RArrange _ _ lev ([],,a) _ _).
-
- intros; apply nd_rule. unfold PCFRule. simpl.
- exists (RArrange _ _ _ _ _ (RCanR _)).
- apply (PCF_RArrange _ _ lev (a,,[]) _ _).
-
- intros; apply nd_rule. unfold PCFRule. simpl.
- exists (RArrange _ _ _ _ _ (RuCanL _)).
- apply (PCF_RArrange _ _ lev _ ([],,a) _).
-
- intros; apply nd_rule. unfold PCFRule. simpl.
- exists (RArrange _ _ _ _ _ (RuCanR _)).
- apply (PCF_RArrange _ _ lev _ (a,,[]) _).
- Defined.
-
- Instance OrgPCF_SequentND_Relation Γ Δ lev : SequentND_Relation (PCF_sequent_join Γ Δ lev) (OrgPCF Γ Δ lev).
- admit.
- Defined.
-
- Definition OrgPCF_ContextND_Relation Γ Δ lev
- : @ContextND_Relation _ _ _ _ _ (PCF_sequent_join Γ Δ lev) (OrgPCF Γ Δ lev) (OrgPCF_SequentND_Relation Γ Δ lev).
- admit.
- Defined.
-
- (* 5.1.3 *)
- Instance PCF Γ Δ lev : ProgrammingLanguage :=
- { pl_cnd := PCF_sequent_join Γ Δ lev
- ; pl_eqv := OrgPCF_ContextND_Relation Γ Δ lev
- }.
-
- Definition SystemFCa_cut Γ Δ : forall a b c, ND (OrgR Γ Δ) ([(a,b)],,[(b,c)]) [(a,c)].
- intros.
- destruct b.
- destruct o.
- destruct c.
- destruct o.
-
- (* when the cut is a single leaf and the RHS is a single leaf: *)
- (*
- eapply nd_comp.
- eapply nd_prod.
- apply nd_id.
- eapply nd_rule.
- set (@org_fc) as ofc.
- set (RArrange Γ Δ _ _ _ (RuCanL [l0])) as rule.
- apply org_fc with (r:=RArrange _ _ _ _ _ (RuCanL [_])).
- auto.
- eapply nd_comp; [ idtac | eapply nd_rule; apply org_fc with (r:=RArrange _ _ _ _ _ (RCanL _)) ].
- apply nd_rule.
- destruct l.
- destruct l0.
- assert (h0=h2). admit.
- subst.
- apply org_fc with (r:=@RLet Γ Δ [] a h1 h h2).
- auto.
- auto.
- *)
- admit.
- apply (Prelude_error "systemfc cut rule invoked with [a|=[b]] [[b]|=[]]").
- apply (Prelude_error "systemfc cut rule invoked with [a|=[b]] [[b]|=[x,,y]]").
- apply (Prelude_error "systemfc rule invoked with [a|=[]] [[]|=c]").
- apply (Prelude_error "systemfc rule invoked with [a|=[b,,c]] [[b,,c]|=z]").
- Defined.
-
- Instance SystemFCa_sequents Γ Δ : @SequentND _ (OrgR Γ Δ) _ _ :=
- { snd_cut := SystemFCa_cut Γ Δ }.
- apply Build_SequentND.
- intros.
- induction a.
- destruct a; simpl.
- (*
- apply nd_rule.
- destruct l.
- apply org_fc with (r:=RVar _ _ _ _).
- auto.
- apply nd_rule.
- apply org_fc with (r:=RVoid _ _ ).
- auto.
- eapply nd_comp.
- eapply nd_comp; [ apply nd_llecnac | idtac ].
- apply (nd_prod IHa1 IHa2).
- apply nd_rule.
- apply org_fc with (r:=RJoin _ _ _ _ _ _).
- auto.
- admit.
- *)
- admit.
- admit.
- admit.
- admit.
- Defined.
-
- Definition SystemFCa_left Γ Δ a b c : ND (OrgR Γ Δ) [(b,c)] [((a,,b),(a,,c))].
- admit.
- (*
- eapply nd_comp; [ apply nd_llecnac | eapply nd_comp; [ idtac | idtac ] ].
- eapply nd_prod; [ apply snd_initial | apply nd_id ].
- apply nd_rule.
- apply org_fc with (r:=RJoin Γ Δ a b a c).
- auto.
- *)
- Defined.
-
- Definition SystemFCa_right Γ Δ a b c : ND (OrgR Γ Δ) [(b,c)] [((b,,a),(c,,a))].
- admit.
- (*
- eapply nd_comp; [ apply nd_rlecnac | eapply nd_comp; [ idtac | idtac ] ].
- eapply nd_prod; [ apply nd_id | apply snd_initial ].
- apply nd_rule.
- apply org_fc with (r:=RJoin Γ Δ b a c a).
- auto.
- *)
- Defined.
-
- Instance SystemFCa_sequent_join Γ Δ : @ContextND _ _ _ _ (SystemFCa_sequents Γ Δ) :=
- { cnd_expand_left := fun a b c => SystemFCa_left Γ Δ c a b
- ; cnd_expand_right := fun a b c => SystemFCa_right Γ Δ c a b }.
- (*
- intros; apply nd_rule. simpl.
- apply (org_fc _ _ _ _ ((RArrange _ _ _ _ _ (RCossa _ _ _)))).
- auto.
-
- intros; apply nd_rule. simpl.
- apply (org_fc _ _ _ _ (RArrange _ _ _ _ _ (RAssoc _ _ _))); auto.
-
- intros; apply nd_rule. simpl.
- apply (org_fc _ _ _ _ (RArrange _ _ _ _ _ (RCanL _))); auto.
-
- intros; apply nd_rule. simpl.
- apply (org_fc _ _ _ _ (RArrange _ _ _ _ _ (RCanR _))); auto.
-
- intros; apply nd_rule. simpl.
- apply (org_fc _ _ _ _ (RArrange _ _ _ _ _ (RuCanL _))); auto.
-
- intros; apply nd_rule. simpl.
- apply (org_fc _ _ _ _ (RArrange _ _ _ _ _ (RuCanR _))); auto.
- *)
- admit.
- admit.
- admit.
- admit.
- admit.
- admit.
- Defined.
-
- Instance OrgFC Γ Δ : @ND_Relation _ (OrgR Γ Δ).
- Admitted.
-
- Instance OrgFC_SequentND_Relation Γ Δ : SequentND_Relation (SystemFCa_sequent_join Γ Δ) (OrgFC Γ Δ).
- admit.
- Defined.
-
- Definition OrgFC_ContextND_Relation Γ Δ
- : @ContextND_Relation _ _ _ _ _ (SystemFCa_sequent_join Γ Δ) (OrgFC Γ Δ) (OrgFC_SequentND_Relation Γ Δ).
- admit.
- Defined.
-
- (* 5.1.2 *)
- Instance SystemFCa Γ Δ : @ProgrammingLanguage (LeveledHaskType Γ ★) _ :=
- { pl_eqv := OrgFC_ContextND_Relation Γ Δ
- ; pl_snd := SystemFCa_sequents Γ Δ
- }.
-
-End HaskProofStratified.
Require Import Preamble.
Require Import General.
Require Import NaturalDeduction.
+Require Import NaturalDeductionContext.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import HaskKinds.
Require Import HaskWeakVars.
Require Import HaskWeakTypes.
-Require Import HaskLiteralsAndTyCons.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
Require Import HaskStrongTypes.
Require Import HaskStrong.
Require Import HaskProof.
; let body := t1'+++(rawLatexMath " ")+++t2'
in return (if needparens then (rawLatexMath "(")+++body+++(rawLatexMath ")") else body)
end
- | TyFunApp tfc lt => bind rest = typeListToRawLatexMath false lt
+ | TyFunApp tfc _ _ lt => bind rest = typeListToRawLatexMath false lt
; return (rawLatexMath "{\text{\tt{")+++(toLatexMath (toString tfc))+++(rawLatexMath "}}}")+++
(rawLatexMath "_{")+++(rawLatexMath (toString (length (fst (tyFunKind tfc)))))+++
(rawLatexMath "}")+++
| nil => t''
| lv => (rawLatexMath " ")+++t''+++(rawLatexMath " @ ")+++
(fold_left (fun x y => x+++(rawLatexMath ":")+++y)
- (map (fun l:HaskTyVar Γ ★ => l (fun _ => LatexMath) ite) lv) (rawLatexMath ""))
+ (map (fun l:HaskTyVar Γ _ => l (fun _ => LatexMath) ite) lv) (rawLatexMath ""))
end
end); try apply ConcatenableLatexMath.
try apply VarNameMonad.
Definition judgmentToRawLatexMath (j:Judg) : LatexMath :=
match match j return VarNameStoreM LatexMath with
- | mkJudg Γ Δ Σ₁ Σ₂ =>
+ | mkJudg Γ Δ Σ₁ Σ₂ l =>
bind Σ₁' = treeM (mapOptionTree ltypeToLatexMath Σ₁)
- ; bind Σ₂' = treeM (mapOptionTree ltypeToLatexMath Σ₂)
+ ; bind Σ₂' = treeM (mapOptionTree (fun t => ltypeToLatexMath (t@@l)) Σ₂)
; return treeToLatexMath Σ₁' +++ (rawLatexMath "\vdash") +++ treeToLatexMath Σ₂'
end with
varNameStoreM f => fst (f (varNameStore 0 0 0))
Fixpoint nd_uruleToRawLatexMath {T}{h}{c}(r:@Arrange T h c) : string :=
match r with
- | RLeft _ _ _ r => nd_uruleToRawLatexMath r
- | RRight _ _ _ r => nd_uruleToRawLatexMath r
- | RCanL _ => "CanL"
- | RCanR _ => "CanR"
- | RuCanL _ => "uCanL"
- | RuCanR _ => "uCanR"
- | RAssoc _ _ _ => "Assoc"
- | RCossa _ _ _ => "Cossa"
- | RExch _ _ => "Exch"
- | RWeak _ => "Weak"
- | RCont _ => "Cont"
- | RComp _ _ _ _ _ => "Comp" (* FIXME: do a better job here *)
+ | ALeft _ _ _ r => nd_uruleToRawLatexMath r
+ | ARight _ _ _ r => nd_uruleToRawLatexMath r
+ | AId _ => "Id"
+ | ACanL _ => "CanL"
+ | ACanR _ => "CanR"
+ | AuCanL _ => "uCanL"
+ | AuCanR _ => "uCanR"
+ | AAssoc _ _ _ => "Assoc"
+ | AuAssoc _ _ _ => "Cossa"
+ | AExch _ _ => "Exch"
+ | AWeak _ => "Weak"
+ | ACont _ => "Cont"
+ | AComp _ _ _ _ _ => "Comp" (* FIXME: do a better job here *)
end.
Fixpoint nd_ruleToRawLatexMath {h}{c}(r:Rule h c) : string :=
match r with
- | RArrange _ _ _ _ _ r => nd_uruleToRawLatexMath r
+ | RArrange _ _ _ _ _ _ r => nd_uruleToRawLatexMath r
| RNote _ _ _ _ _ _ => "Note"
| RLit _ _ _ _ => "Lit"
| RVar _ _ _ _ => "Var"
| RGlobal _ _ _ _ _ => "Global"
| RLam _ _ _ _ _ _ => "Abs"
| RCast _ _ _ _ _ _ _ => "Cast"
- | RAbsT _ _ _ _ _ _ => "AbsT"
+ | RAbsT _ _ _ _ _ _ _ => "AbsT"
| RAppT _ _ _ _ _ _ _ => "AppT"
| RAppCo _ _ _ _ _ _ _ _ _ => "AppCo"
| RAbsCo _ _ _ _ _ _ _ _ => "AbsCo"
| RApp _ _ _ _ _ _ _ => "App"
- | RLet _ _ _ _ _ _ _ => "Let"
- | RJoin _ _ _ _ _ _ => "RJoin"
+ | RCut _ _ _ _ _ _ _ _ => "Cut"
+ | RLeft _ _ _ _ _ _ => "Left"
+ | RRight _ _ _ _ _ _ => "Right"
| RLetRec _ _ _ _ _ _ => "LetRec"
| RCase _ _ _ _ _ _ _ _ => "Case"
| RBrak _ _ _ _ _ _ => "Brak"
| REsc _ _ _ _ _ _ => "Esc"
- | RVoid _ _ => "RVoid"
+ | RVoid _ _ _ => "RVoid"
end.
Fixpoint nd_hideURule {T}{h}{c}(r:@Arrange T h c) : bool :=
match r with
- | RLeft _ _ _ r => nd_hideURule r
- | RRight _ _ _ r => nd_hideURule r
- | RCanL _ => true
- | RCanR _ => true
- | RuCanL _ => true
- | RuCanR _ => true
- | RAssoc _ _ _ => true
- | RCossa _ _ _ => true
- | RExch (T_Leaf None) b => true
- | RExch a (T_Leaf None) => true
- | RWeak (T_Leaf None) => true
- | RCont (T_Leaf None) => true
- | RComp _ _ _ _ _ => false (* FIXME: do better *)
+ | ALeft _ _ _ r => nd_hideURule r
+ | ARight _ _ _ r => nd_hideURule r
+ | ACanL _ => true
+ | ACanR _ => true
+ | AuCanL _ => true
+ | AuCanR _ => true
+ | AAssoc _ _ _ => true
+ | AuAssoc _ _ _ => true
+ | AExch (T_Leaf None) b => true
+ | AExch a (T_Leaf None) => true
+ | AWeak (T_Leaf None) => true
+ | ACont (T_Leaf None) => true
+ | AComp _ _ _ _ _ => false (* FIXME: do better *)
| _ => false
end.
Fixpoint nd_hideRule {h}{c}(r:Rule h c) : bool :=
match r with
- | RArrange _ _ _ _ _ r => nd_hideURule r
- | RVoid _ _ => true
- | RJoin _ _ _ _ _ _ => true
+ | RArrange _ _ _ _ _ _ r => nd_hideURule r
+ | RVoid _ _ _ => true
+ | RLeft _ _ _ _ _ _ => true
+ | RRight _ _ _ _ _ _ => true
| _ => false
end.
Require Import Preamble.
Require Import General.
Require Import NaturalDeduction.
+Require Import NaturalDeductionContext.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Init.Specif.
Definition judg2exprType (j:Judg) : Type :=
match j with
- (Γ > Δ > Σ |- τ) => forall (ξ:ExprVarResolver Γ) vars, Σ = mapOptionTree ξ vars ->
- FreshM (ITree _ (fun t => Expr Γ Δ ξ t) τ)
+ (Γ > Δ > Σ |- τ @ l) => forall (ξ:ExprVarResolver Γ) vars, Σ = mapOptionTree ξ vars ->
+ FreshM (ITree _ (fun t => Expr Γ Δ ξ t l) τ)
end.
- Definition justOne Γ Δ ξ τ : ITree _ (fun t => Expr Γ Δ ξ t) [τ] -> Expr Γ Δ ξ τ.
+ Definition justOne Γ Δ ξ τ l : ITree _ (fun t => Expr Γ Δ ξ t l) [τ] -> Expr Γ Δ ξ τ l.
intros.
inversion X; auto.
Defined.
Defined.
Lemma update_branches : forall Γ (ξ:VV -> LeveledHaskType Γ ★) lev l1 l2 q,
- update_ξ ξ lev (app l1 l2) q = update_ξ (update_ξ ξ lev l2) lev l1 q.
+ update_xi ξ lev (app l1 l2) q = update_xi (update_xi ξ lev l2) lev l1 q.
intros.
induction l1.
reflexivity.
Lemma fresh_lemma'' Γ
: forall types ξ lev,
FreshM { varstypes : _
- | mapOptionTree (update_ξ(Γ:=Γ) ξ lev (leaves varstypes)) (mapOptionTree (@fst _ _) varstypes) = (types @@@ lev)
+ | mapOptionTree (update_xi(Γ:=Γ) ξ lev (leaves varstypes)) (mapOptionTree (@fst _ _) varstypes) = (types @@@ lev)
/\ distinct (leaves (mapOptionTree (@fst _ _) varstypes)) }.
admit.
Defined.
Lemma fresh_lemma' Γ
: forall types vars Σ ξ lev, Σ = mapOptionTree ξ vars ->
FreshM { varstypes : _
- | mapOptionTree (update_ξ(Γ:=Γ) ξ lev (leaves varstypes)) vars = Σ
- /\ mapOptionTree (update_ξ ξ lev (leaves varstypes)) (mapOptionTree (@fst _ _) varstypes) = (types @@@ lev)
+ | mapOptionTree (update_xi(Γ:=Γ) ξ lev (leaves varstypes)) vars = Σ
+ /\ mapOptionTree (update_xi ξ lev (leaves varstypes)) (mapOptionTree (@fst _ _) varstypes) = (types @@@ lev)
/\ distinct (leaves (mapOptionTree (@fst _ _) varstypes)) }.
induction types.
intros; destruct a.
intros vars Σ ξ lev pf; refine (bind x2 = IHtypes2 vars Σ ξ lev pf; _).
apply FreshMon.
destruct x2 as [vt2 [pf21 [pf22 pfdist]]].
- refine (bind x1 = IHtypes1 (vars,,(mapOptionTree (@fst _ _) vt2)) (Σ,,(types2@@@lev)) (update_ξ ξ lev
+ refine (bind x1 = IHtypes1 (vars,,(mapOptionTree (@fst _ _) vt2)) (Σ,,(types2@@@lev)) (update_xi ξ lev
(leaves vt2)) _ _; return _).
apply FreshMon.
simpl.
Lemma fresh_lemma Γ ξ vars Σ Σ' lev
: Σ = mapOptionTree ξ vars ->
FreshM { vars' : _
- | mapOptionTree (update_ξ(Γ:=Γ) ξ lev ((vars',Σ')::nil)) vars = Σ
- /\ mapOptionTree (update_ξ ξ lev ((vars',Σ')::nil)) [vars'] = [Σ' @@ lev] }.
+ | mapOptionTree (update_xi(Γ:=Γ) ξ lev ((vars',Σ')::nil)) vars = Σ
+ /\ mapOptionTree (update_xi ξ lev ((vars',Σ')::nil)) [vars'] = [Σ' @@ lev] }.
intros.
set (fresh_lemma' Γ [Σ'] vars Σ ξ lev H) as q.
refine (q >>>= fun q' => return _).
inversion pf2.
Defined.
- Definition ujudg2exprType Γ (ξ:ExprVarResolver Γ)(Δ:CoercionEnv Γ) Σ τ : Type :=
- forall vars, Σ = mapOptionTree ξ vars -> FreshM (ITree _ (fun t => Expr Γ Δ ξ t) τ).
+ Definition ujudg2exprType Γ (ξ:ExprVarResolver Γ)(Δ:CoercionEnv Γ) Σ τ l : Type :=
+ forall vars, Σ = mapOptionTree ξ vars -> FreshM (ITree _ (fun t => Expr Γ Δ ξ t l) τ).
- Definition urule2expr : forall Γ Δ h j t (r:@Arrange _ h j) (ξ:VV -> LeveledHaskType Γ ★),
- ujudg2exprType Γ ξ Δ h t ->
- ujudg2exprType Γ ξ Δ j t
+ Definition urule2expr : forall Γ Δ h j t l (r:@Arrange _ h j) (ξ:VV -> LeveledHaskType Γ ★),
+ ujudg2exprType Γ ξ Δ h t l ->
+ ujudg2exprType Γ ξ Δ j t l
.
intros Γ Δ.
- refine (fix urule2expr h j t (r:@Arrange _ h j) ξ {struct r} :
- ujudg2exprType Γ ξ Δ h t ->
- ujudg2exprType Γ ξ Δ j t :=
+ refine (fix urule2expr h j t l (r:@Arrange _ h j) ξ {struct r} :
+ ujudg2exprType Γ ξ Δ h t l ->
+ ujudg2exprType Γ ξ Δ j t l :=
match r as R in Arrange H C return
- ujudg2exprType Γ ξ Δ H t ->
- ujudg2exprType Γ ξ Δ C t
+ ujudg2exprType Γ ξ Δ H t l ->
+ ujudg2exprType Γ ξ Δ C t l
with
- | RLeft h c ctx r => let case_RLeft := tt in (fun e => _) (urule2expr _ _ _ r)
- | RRight h c ctx r => let case_RRight := tt in (fun e => _) (urule2expr _ _ _ r)
- | RCanL a => let case_RCanL := tt in _
- | RCanR a => let case_RCanR := tt in _
- | RuCanL a => let case_RuCanL := tt in _
- | RuCanR a => let case_RuCanR := tt in _
- | RAssoc a b c => let case_RAssoc := tt in _
- | RCossa a b c => let case_RCossa := tt in _
- | RExch a b => let case_RExch := tt in _
- | RWeak a => let case_RWeak := tt in _
- | RCont a => let case_RCont := tt in _
- | RComp a b c f g => let case_RComp := tt in (fun e1 e2 => _) (urule2expr _ _ _ f) (urule2expr _ _ _ g)
+ | ALeft h c ctx r => let case_ALeft := tt in (fun e => _) (urule2expr _ _ _ _ r)
+ | ARight h c ctx r => let case_ARight := tt in (fun e => _) (urule2expr _ _ _ _ r)
+ | AId a => let case_AId := tt in _
+ | ACanL a => let case_ACanL := tt in _
+ | ACanR a => let case_ACanR := tt in _
+ | AuCanL a => let case_AuCanL := tt in _
+ | AuCanR a => let case_AuCanR := tt in _
+ | AAssoc a b c => let case_AAssoc := tt in _
+ | AuAssoc a b c => let case_AuAssoc := tt in _
+ | AExch a b => let case_AExch := tt in _
+ | AWeak a => let case_AWeak := tt in _
+ | ACont a => let case_ACont := tt in _
+ | AComp a b c f g => let case_AComp := tt in (fun e1 e2 => _) (urule2expr _ _ _ _ f) (urule2expr _ _ _ _ g)
end); clear urule2expr; intros.
- destruct case_RCanL.
+ destruct case_AId.
+ apply X.
+
+ destruct case_ACanL.
simpl; unfold ujudg2exprType; intros.
simpl in X.
apply (X ([],,vars)).
simpl; rewrite <- H; auto.
- destruct case_RCanR.
+ destruct case_ACanR.
simpl; unfold ujudg2exprType; intros.
simpl in X.
apply (X (vars,,[])).
simpl; rewrite <- H; auto.
- destruct case_RuCanL.
+ destruct case_AuCanL.
simpl; unfold ujudg2exprType; intros.
destruct vars; try destruct o; inversion H.
simpl in X.
apply (X vars2); auto.
- destruct case_RuCanR.
+ destruct case_AuCanR.
simpl; unfold ujudg2exprType; intros.
destruct vars; try destruct o; inversion H.
simpl in X.
apply (X vars1); auto.
- destruct case_RAssoc.
+ destruct case_AAssoc.
simpl; unfold ujudg2exprType; intros.
simpl in X.
destruct vars; try destruct o; inversion H.
apply (X (vars1_1,,(vars1_2,,vars2))).
subst; auto.
- destruct case_RCossa.
+ destruct case_AuAssoc.
simpl; unfold ujudg2exprType; intros.
simpl in X.
destruct vars; try destruct o; inversion H.
apply (X ((vars1,,vars2_1),,vars2_2)).
subst; auto.
- destruct case_RExch.
+ destruct case_AExch.
simpl; unfold ujudg2exprType ; intros.
simpl in X.
destruct vars; try destruct o; inversion H.
apply (X (vars2,,vars1)).
inversion H; subst; auto.
- destruct case_RWeak.
+ destruct case_AWeak.
simpl; unfold ujudg2exprType; intros.
simpl in X.
apply (X []).
auto.
- destruct case_RCont.
+ destruct case_ACont.
simpl; unfold ujudg2exprType ; intros.
simpl in X.
apply (X (vars,,vars)).
rewrite <- H.
auto.
- destruct case_RLeft.
+ destruct case_ALeft.
intro vars; unfold ujudg2exprType; intro H.
destruct vars; try destruct o; inversion H.
apply (fun q => e ξ q vars2 H2).
simpl.
reflexivity.
- destruct case_RRight.
+ destruct case_ARight.
intro vars; unfold ujudg2exprType; intro H.
destruct vars; try destruct o; inversion H.
apply (fun q => e ξ q vars1 H1).
simpl.
reflexivity.
- destruct case_RComp.
+ destruct case_AComp.
apply e2.
apply e1.
apply X.
Defined.
Definition letrec_helper Γ Δ l (varstypes:Tree ??(VV * HaskType Γ ★)) ξ' :
- ITree (LeveledHaskType Γ ★)
- (fun t : LeveledHaskType Γ ★ => Expr Γ Δ ξ' t)
- (mapOptionTree (ξ' ○ (@fst _ _)) varstypes)
+ ITree (HaskType Γ ★)
+ (fun t : HaskType Γ ★ => Expr Γ Δ ξ' t l)
+ (mapOptionTree (unlev ○ ξ' ○ (@fst _ _)) varstypes)
-> ELetRecBindings Γ Δ ξ' l varstypes.
intros.
induction varstypes.
simpl.
destruct (eqd_dec h0 l).
rewrite <- e0.
+ simpl in X.
+ subst.
apply X.
apply (Prelude_error "level mismatch; should never happen").
apply (Prelude_error "letrec type mismatch; should never happen").
exists x; auto.
Defined.
- Definition fix_indexing X (F:X->Type)(J:X->Type)(t:Tree ??{ x:X & F x })
- : ITree { x:X & F x } (fun x => J (projT1 x)) t
- -> ITree X (fun x:X => J x) (mapOptionTree (@projT1 _ _) t).
+ Definition fix_indexing X Y (J:X->Type)(t:Tree ??(X*Y))
+ : ITree (X * Y) (fun x => J (fst x)) t
+ -> ITree X (fun x:X => J x) (mapOptionTree (@fst _ _) t).
intro it.
induction it; simpl in *.
apply INone.
Defined.
Definition case_helper tc Γ Δ lev tbranches avars ξ :
- forall pcb:{sac : StrongAltCon & ProofCaseBranch tc Γ Δ lev tbranches avars sac},
- prod (judg2exprType (pcb_judg (projT2 pcb))) {vars' : Tree ??VV & pcb_freevars (projT2 pcb) = mapOptionTree ξ vars'} ->
+ forall pcb:(StrongAltCon * Tree ??(LeveledHaskType Γ ★)),
+ prod (judg2exprType (@pcb_judg tc Γ Δ lev tbranches avars (fst pcb) (snd pcb)))
+ {vars' : Tree ??VV & (snd pcb) = mapOptionTree ξ vars'} ->
((fun sac => FreshM
{ scb : StrongCaseBranchWithVVs VV eqdec_vv tc avars sac
- & Expr (sac_Γ sac Γ) (sac_Δ sac Γ avars (weakCK'' Δ)) (scbwv_ξ scb ξ lev) (weakLT' (tbranches @@ lev)) }) (projT1 pcb)).
+ & Expr (sac_gamma sac Γ) (sac_delta sac Γ avars (weakCK'' Δ)) (scbwv_xi scb ξ lev)
+ (weakT' tbranches) (weakL' lev) }) (fst pcb)).
intro pcb.
intro X.
simpl in X.
destruct s as [vars vars_pf].
refine (bind localvars = fresh_lemma' _ (unleaves (vec2list (sac_types sac _ avars))) vars
- (mapOptionTree weakLT' (pcb_freevars pcb)) (weakLT' ○ ξ) (weakL' lev) _ ; _).
+ (mapOptionTree weakLT' pcb) (weakLT' ○ ξ) (weakL' lev) _ ; _).
apply FreshMon.
rewrite vars_pf.
rewrite <- mapOptionTree_compose.
cut (distinct (vec2list localvars'')). intro H'''.
set (@Build_StrongCaseBranchWithVVs _ _ _ _ avars sac localvars'' H''') as scb.
- refine (bind q = (f (scbwv_ξ scb ξ lev) (vars,,(unleaves (vec2list (scbwv_exprvars scb)))) _) ; return _).
+ refine (bind q = (f (scbwv_xi scb ξ lev) (vars,,(unleaves (vec2list (scbwv_exprvars scb)))) _) ; return _).
apply FreshMon.
simpl.
- unfold scbwv_ξ.
+ unfold scbwv_xi.
rewrite vars_pf.
rewrite <- mapOptionTree_compose.
clear localvars_pf1.
Defined.
Definition gather_branch_variables
- Γ Δ (ξ:VV -> LeveledHaskType Γ ★) tc avars tbranches lev (alts:Tree ?? {sac : StrongAltCon &
- ProofCaseBranch tc Γ Δ lev tbranches avars sac})
+ Γ Δ
+ (ξ:VV -> LeveledHaskType Γ ★) tc avars tbranches lev
+ (alts:Tree ??(@StrongAltCon tc * Tree ??(LeveledHaskType Γ ★)))
:
forall vars,
- mapOptionTreeAndFlatten (fun x => pcb_freevars(Γ:=Γ) (projT2 x)) alts = mapOptionTree ξ vars
- -> ITree Judg judg2exprType (mapOptionTree (fun x => pcb_judg (projT2 x)) alts)
- -> ITree _ (fun q => prod (judg2exprType (pcb_judg (projT2 q)))
- { vars' : _ & pcb_freevars (projT2 q) = mapOptionTree ξ vars' })
+ mapOptionTreeAndFlatten (fun x => snd x) alts = mapOptionTree ξ vars
+ -> ITree Judg judg2exprType (mapOptionTree (fun x => @pcb_judg tc Γ Δ lev avars tbranches (fst x) (snd x)) alts)
+ -> ITree _ (fun q => prod (judg2exprType (@pcb_judg tc Γ Δ lev avars tbranches (fst q) (snd q)))
+ { vars' : _ & (snd q) = mapOptionTree ξ vars' })
alts.
induction alts;
intro vars;
simpl in *.
apply ileaf in source.
apply ILeaf.
- destruct s as [sac pcb].
+ destruct p as [sac pcb].
simpl in *.
split.
intros.
Defined.
+ Lemma manyFresh : forall Γ Σ (ξ0:VV -> LeveledHaskType Γ ★),
+ FreshM { vars : _ & { ξ : VV -> LeveledHaskType Γ ★ & Σ = mapOptionTree ξ vars } }.
+ intros Γ Σ.
+ induction Σ; intro ξ.
+ destruct a.
+ destruct l as [τ l].
+ set (fresh_lemma' Γ [τ] [] [] ξ l (refl_equal _)) as q.
+ refine (q >>>= fun q' => return _).
+ apply FreshMon.
+ clear q.
+ destruct q' as [varstypes [pf1 [pf2 distpf]]].
+ exists (mapOptionTree (@fst _ _) varstypes).
+ exists (update_xi ξ l (leaves varstypes)).
+ symmetry; auto.
+ refine (return _).
+ exists [].
+ exists ξ; auto.
+ refine (bind f1 = IHΣ1 ξ ; _).
+ apply FreshMon.
+ destruct f1 as [vars1 [ξ1 pf1]].
+ refine (bind f2 = IHΣ2 ξ1 ; _).
+ apply FreshMon.
+ destruct f2 as [vars2 [ξ2 pf22]].
+ refine (return _).
+ exists (vars1,,vars2).
+ exists ξ2.
+ simpl.
+ rewrite pf22.
+ rewrite pf1.
+ admit. (* freshness assumption *)
+ Defined.
+
+ Definition rlet Γ Δ Σ₁ Σ₂ σ₁ σ₂ p :
+ forall (X_ : ITree Judg judg2exprType
+ ([Γ > Δ > Σ₁ |- [σ₁] @ p],, [Γ > Δ > [σ₁ @@ p],, Σ₂ |- [σ₂] @ p])),
+ ITree Judg judg2exprType [Γ > Δ > Σ₁,, Σ₂ |- [σ₂] @ p].
+ intros.
+ apply ILeaf.
+ simpl in *; intros.
+ destruct vars; try destruct o; inversion H.
+
+ refine (fresh_lemma _ ξ _ _ σ₁ p H2 >>>= (fun pf => _)).
+ apply FreshMon.
+
+ destruct pf as [ vnew [ pf1 pf2 ]].
+ set (update_xi ξ p (((vnew, σ₁ )) :: nil)) as ξ' in *.
+ inversion X_.
+ apply ileaf in X.
+ apply ileaf in X0.
+ simpl in *.
+
+ refine (X ξ vars1 _ >>>= fun X0' => _).
+ apply FreshMon.
+ simpl.
+ auto.
+
+ refine (X0 ξ' ([vnew],,vars2) _ >>>= fun X1' => _).
+ apply FreshMon.
+ simpl.
+ rewrite pf2.
+ rewrite pf1.
+ reflexivity.
+ apply FreshMon.
+
+ apply ILeaf.
+ apply ileaf in X1'.
+ apply ileaf in X0'.
+ simpl in *.
+ apply ELet with (ev:=vnew)(tv:=σ₁).
+ apply X0'.
+ apply X1'.
+ Defined.
+
+ Definition vartree Γ Δ Σ lev ξ :
+ forall vars, Σ @@@ lev = mapOptionTree ξ vars ->
+ ITree (HaskType Γ ★) (fun t : HaskType Γ ★ => Expr Γ Δ ξ t lev) Σ.
+ induction Σ; intros.
+ destruct a.
+ intros; simpl in *.
+ apply ILeaf.
+ destruct vars; try destruct o; inversion H.
+ set (EVar Γ Δ ξ v) as q.
+ rewrite <- H1 in q.
+ apply q.
+ intros.
+ apply INone.
+ intros.
+ destruct vars; try destruct o; inversion H.
+ apply IBranch.
+ eapply IHΣ1.
+ apply H1.
+ eapply IHΣ2.
+ apply H2.
+ Defined.
+
+
+ Definition rdrop Γ Δ Σ₁ Σ₁₂ a lev :
+ ITree Judg judg2exprType [Γ > Δ > Σ₁ |- a,,Σ₁₂ @ lev] ->
+ ITree Judg judg2exprType [Γ > Δ > Σ₁ |- a @ lev].
+ intros.
+ apply ileaf in X.
+ apply ILeaf.
+ simpl in *.
+ intros.
+ set (X ξ vars H) as q.
+ simpl in q.
+ refine (q >>>= fun q' => return _).
+ apply FreshMon.
+ inversion q'.
+ apply X0.
+ Defined.
+
+ Definition rdrop' Γ Δ Σ₁ Σ₁₂ a lev :
+ ITree Judg judg2exprType [Γ > Δ > Σ₁ |- Σ₁₂,,a @ lev] ->
+ ITree Judg judg2exprType [Γ > Δ > Σ₁ |- a @ lev].
+ intros.
+ apply ileaf in X.
+ apply ILeaf.
+ simpl in *.
+ intros.
+ set (X ξ vars H) as q.
+ simpl in q.
+ refine (q >>>= fun q' => return _).
+ apply FreshMon.
+ inversion q'.
+ auto.
+ Defined.
+
+ Definition rdrop'' Γ Δ Σ₁ Σ₁₂ lev :
+ ITree Judg judg2exprType [Γ > Δ > [],,Σ₁ |- Σ₁₂ @ lev] ->
+ ITree Judg judg2exprType [Γ > Δ > Σ₁ |- Σ₁₂ @ lev].
+ intros.
+ apply ileaf in X.
+ apply ILeaf.
+ simpl in *; intros.
+ eapply X with (vars:=[],,vars).
+ rewrite H; reflexivity.
+ Defined.
+
+ Definition rdrop''' Γ Δ a Σ₁ Σ₁₂ lev :
+ ITree Judg judg2exprType [Γ > Δ > Σ₁ |- Σ₁₂ @ lev] ->
+ ITree Judg judg2exprType [Γ > Δ > a,,Σ₁ |- Σ₁₂ @ lev].
+ intros.
+ apply ileaf in X.
+ apply ILeaf.
+ simpl in *; intros.
+ destruct vars; try destruct o; inversion H.
+ eapply X with (vars:=vars2).
+ auto.
+ Defined.
+
+ Definition rassoc Γ Δ Σ₁ a b c lev :
+ ITree Judg judg2exprType [Γ > Δ > ((a,,b),,c) |- Σ₁ @ lev] ->
+ ITree Judg judg2exprType [Γ > Δ > (a,,(b,,c)) |- Σ₁ @ lev].
+ intros.
+ apply ileaf in X.
+ apply ILeaf.
+ simpl in *; intros.
+ destruct vars; try destruct o; inversion H.
+ destruct vars2; try destruct o; inversion H2.
+ apply X with (vars:=(vars1,,vars2_1),,vars2_2).
+ subst; reflexivity.
+ Defined.
+
+ Definition rassoc' Γ Δ Σ₁ a b c lev :
+ ITree Judg judg2exprType [Γ > Δ > (a,,(b,,c)) |- Σ₁ @ lev] ->
+ ITree Judg judg2exprType [Γ > Δ > ((a,,b),,c) |- Σ₁ @ lev].
+ intros.
+ apply ileaf in X.
+ apply ILeaf.
+ simpl in *; intros.
+ destruct vars; try destruct o; inversion H.
+ destruct vars1; try destruct o; inversion H1.
+ apply X with (vars:=vars1_1,,(vars1_2,,vars2)).
+ subst; reflexivity.
+ Defined.
+
+ Definition swapr Γ Δ Σ₁ a b c lev :
+ ITree Judg judg2exprType [Γ > Δ > ((a,,b),,c) |- Σ₁ @ lev] ->
+ ITree Judg judg2exprType [Γ > Δ > ((b,,a),,c) |- Σ₁ @ lev].
+ intros.
+ apply ileaf in X.
+ apply ILeaf.
+ simpl in *; intros.
+ destruct vars; try destruct o; inversion H.
+ destruct vars1; try destruct o; inversion H1.
+ apply X with (vars:=(vars1_2,,vars1_1),,vars2).
+ subst; reflexivity.
+ Defined.
+
+ Definition rdup Γ Δ Σ₁ a c lev :
+ ITree Judg judg2exprType [Γ > Δ > ((a,,a),,c) |- Σ₁ @ lev] ->
+ ITree Judg judg2exprType [Γ > Δ > (a,,c) |- Σ₁ @ lev].
+ intros.
+ apply ileaf in X.
+ apply ILeaf.
+ simpl in *; intros.
+ destruct vars; try destruct o; inversion H.
+ apply X with (vars:=(vars1,,vars1),,vars2). (* is this allowed? *)
+ subst; reflexivity.
+ Defined.
+
+ (* holy cow this is ugly *)
+ Definition rcut Γ Δ Σ₃ lev Σ₁₂ :
+ forall Σ₁ Σ₂,
+ ITree Judg judg2exprType [Γ > Δ > Σ₁ |- Σ₁₂ @ lev] ->
+ ITree Judg judg2exprType [Γ > Δ > Σ₁₂ @@@ lev,,Σ₂ |- [Σ₃] @ lev] ->
+ ITree Judg judg2exprType [Γ > Δ > Σ₁,,Σ₂ |- [Σ₃] @ lev].
+
+ induction Σ₁₂.
+ intros.
+ destruct a.
+
+ eapply rlet.
+ apply IBranch.
+ apply X.
+ apply X0.
+
+ simpl in X0.
+ apply rdrop'' in X0.
+ apply rdrop'''.
+ apply X0.
+
+ intros.
+ simpl in X0.
+ apply rassoc in X0.
+ set (IHΣ₁₂1 _ _ (rdrop _ _ _ _ _ _ X) X0) as q.
+ set (IHΣ₁₂2 _ (Σ₁,,Σ₂) (rdrop' _ _ _ _ _ _ X)) as q'.
+ apply rassoc' in q.
+ apply swapr in q.
+ apply rassoc in q.
+ set (q' q) as q''.
+ apply rassoc' in q''.
+ apply rdup in q''.
+ apply q''.
+ Defined.
Definition rule2expr : forall h j (r:Rule h j), ITree _ judg2exprType h -> ITree _ judg2exprType j.
intros h j r.
refine (match r as R in Rule H C return ITree _ judg2exprType H -> ITree _ judg2exprType C with
- | RArrange a b c d e r => let case_RURule := tt in _
+ | RArrange a b c d e l r => let case_RURule := tt in _
| RNote Γ Δ Σ τ l n => let case_RNote := tt in _
| RLit Γ Δ l _ => let case_RLit := tt in _
| RVar Γ Δ σ p => let case_RVar := tt in _
| RGlobal Γ Δ σ l wev => let case_RGlobal := tt in _
| RLam Γ Δ Σ tx te x => let case_RLam := tt in _
| RCast Γ Δ Σ σ τ γ x => let case_RCast := tt in _
- | RAbsT Γ Δ Σ κ σ a => let case_RAbsT := tt in _
+ | RAbsT Γ Δ Σ κ σ a n => let case_RAbsT := tt in _
| RAppT Γ Δ Σ κ σ τ y => let case_RAppT := tt in _
| RAppCo Γ Δ Σ κ σ₁ σ₂ γ σ l => let case_RAppCo := tt in _
| RAbsCo Γ Δ Σ κ σ σ₁ σ₂ y => let case_RAbsCo := tt in _
| RApp Γ Δ Σ₁ Σ₂ tx te p => let case_RApp := tt in _
- | RLet Γ Δ Σ₁ Σ₂ σ₁ σ₂ p => let case_RLet := tt in _
- | RJoin Γ p lri m x q => let case_RJoin := tt in _
- | RVoid _ _ => let case_RVoid := tt in _
+ | RCut Γ Δ Σ Σ₁ Σ₁₂ Σ₂ Σ₃ l => let case_RCut := tt in _
+ | RLeft Γ Δ Σ₁ Σ₂ Σ l => let case_RLeft := tt in _
+ | RRight Γ Δ Σ₁ Σ₂ Σ l => let case_RRight := tt in _
+ | RVoid _ _ l => let case_RVoid := tt in _
| RBrak Σ a b c n m => let case_RBrak := tt in _
| REsc Σ a b c n m => let case_REsc := tt in _
| RCase Γ Δ lev tc Σ avars tbranches alts => let case_RCase := tt in _
destruct case_RURule.
apply ILeaf. simpl. intros.
- set (@urule2expr a b _ _ e r0 ξ) as q.
- set (fun z => q z) as q'.
- simpl in q'.
- apply q' with (vars:=vars).
- clear q' q.
+ set (@urule2expr a b _ _ e l r0 ξ) as q.
unfold ujudg2exprType.
+ unfold ujudg2exprType in q.
+ apply q with (vars:=vars).
intros.
apply X_ with (vars:=vars0).
auto.
destruct case_RVar.
apply ILeaf; simpl; intros; refine (return ILeaf _ _).
- destruct vars; simpl in H; inversion H; destruct o. inversion H1. rewrite H2.
- apply EVar.
+ destruct vars; simpl in H; inversion H; destruct o. inversion H1.
+ set (@EVar _ _ _ Δ ξ v) as q.
+ rewrite <- H2 in q.
+ simpl in q.
+ apply q.
inversion H.
destruct case_RGlobal.
apply ILeaf; simpl; intros; refine (return ILeaf _ _).
apply EGlobal.
- apply wev.
destruct case_RLam.
apply ILeaf.
refine (fresh_lemma _ ξ vars _ tx x H >>>= (fun pf => _)).
apply FreshMon.
destruct pf as [ vnew [ pf1 pf2 ]].
- set (update_ξ ξ x (((vnew, tx )) :: nil)) as ξ' in *.
+ set (update_xi ξ x (((vnew, tx )) :: nil)) as ξ' in *.
refine (X_ ξ' (vars,,[vnew]) _ >>>= _).
apply FreshMon.
simpl.
apply ileaf in X. simpl in X.
apply X.
- destruct case_RJoin.
- apply ILeaf; simpl; intros.
- inversion X_.
- apply ileaf in X.
- apply ileaf in X0.
- simpl in *.
- destruct vars; inversion H.
- destruct o; inversion H3.
- refine (X ξ vars1 H3 >>>= fun X' => X0 ξ vars2 H4 >>>= fun X0' => return _).
- apply FreshMon.
- apply FreshMon.
- apply IBranch; auto.
-
destruct case_RApp.
apply ILeaf.
inversion X_.
simpl in *.
apply (EApp _ _ _ _ _ _ q1' q2').
- destruct case_RLet.
- apply ILeaf.
- simpl in *; intros.
- destruct vars; try destruct o; inversion H.
- refine (fresh_lemma _ ξ vars1 _ σ₂ p H1 >>>= (fun pf => _)).
- apply FreshMon.
- destruct pf as [ vnew [ pf1 pf2 ]].
- set (update_ξ ξ p (((vnew, σ₂ )) :: nil)) as ξ' in *.
+ destruct case_RCut.
+ apply rassoc.
+ apply swapr.
+ apply rassoc'.
+
inversion X_.
- apply ileaf in X.
- apply ileaf in X0.
+ subst.
+ clear X_.
+
+ apply rassoc' in X0.
+ apply swapr in X0.
+ apply rassoc in X0.
+
+ induction Σ₃.
+ destruct a.
+ subst.
+ eapply rcut.
+ apply X.
+ apply X0.
+
+ apply ILeaf.
+ simpl.
+ intros.
+ refine (return _).
+ apply INone.
+ set (IHΣ₃1 (rdrop _ _ _ _ _ _ X0)) as q1.
+ set (IHΣ₃2 (rdrop' _ _ _ _ _ _ X0)) as q2.
+ apply ileaf in q1.
+ apply ileaf in q2.
simpl in *.
- refine (X ξ vars2 _ >>>= fun X0' => _).
+ apply ILeaf.
+ simpl.
+ intros.
+ refine (q1 _ _ H >>>= fun q1' => q2 _ _ H >>>= fun q2' => return _).
apply FreshMon.
- auto.
+ apply FreshMon.
+ apply IBranch; auto.
- refine (X0 ξ' (vars1,,[vnew]) _ >>>= fun X1' => _).
+ destruct case_RLeft.
+ apply ILeaf.
+ simpl; intros.
+ destruct vars; try destruct o; inversion H.
+ refine (X_ _ _ H2 >>>= fun X' => return _).
apply FreshMon.
- rewrite H1.
- simpl.
- rewrite pf2.
- rewrite pf1.
- rewrite H1.
- reflexivity.
+ apply IBranch.
+ eapply vartree.
+ apply H1.
+ apply X'.
- refine (return _).
+ destruct case_RRight.
apply ILeaf.
- apply ileaf in X0'.
- apply ileaf in X1'.
- simpl in *.
- apply ELet with (ev:=vnew)(tv:=σ₂).
- apply X0'.
- apply X1'.
+ simpl; intros.
+ destruct vars; try destruct o; inversion H.
+ refine (X_ _ _ H1 >>>= fun X' => return _).
+ apply FreshMon.
+ apply IBranch.
+ apply X'.
+ eapply vartree.
+ apply H2.
destruct case_RVoid.
apply ILeaf; simpl; intros.
apply (ileaf X).
destruct case_RAbsT.
- apply ILeaf; simpl; intros; refine (X_ (weakLT ○ ξ) vars _ >>>= fun X => return ILeaf _ _). apply FreshMon.
+ apply ILeaf; simpl; intros; refine (X_ (weakLT_ ○ ξ) vars _ >>>= fun X => return ILeaf _ _). apply FreshMon.
rewrite mapOptionTree_compose.
rewrite <- H.
reflexivity.
apply ileaf in X. simpl in *.
- apply ETyLam.
+ apply (ETyLam _ _ _ _ _ _ n).
apply X.
destruct case_RAppCo.
apply ILeaf; simpl; intros.
refine (bind ξvars = fresh_lemma' _ y _ _ _ t H; _). apply FreshMon.
destruct ξvars as [ varstypes [ pf1[ pf2 pfdist]]].
- refine (X_ ((update_ξ ξ t (leaves varstypes)))
- (vars,,(mapOptionTree (@fst _ _) varstypes)) _ >>>= fun X => return _); clear X_. apply FreshMon.
+ refine (X_ ((update_xi ξ t (leaves varstypes)))
+ ((mapOptionTree (@fst _ _) varstypes),,vars) _ >>>= fun X => return _); clear X_. apply FreshMon.
simpl.
rewrite pf2.
rewrite pf1.
inversion X; subst; clear X.
apply (@ELetRec _ _ _ _ _ _ _ varstypes).
+ auto.
apply (@letrec_helper Γ Δ t varstypes).
- rewrite <- pf2 in X1.
rewrite mapOptionTree_compose.
+ rewrite mapOptionTree_compose.
+ rewrite pf2.
+ replace ((mapOptionTree unlev (y @@@ t))) with y.
+ apply X0.
+ clear pf1 X0 X1 pfdist pf2 vars varstypes.
+ induction y; try destruct a; auto.
+ rewrite IHy1 at 1.
+ rewrite IHy2 at 1.
+ reflexivity.
+ apply ileaf in X1.
+ simpl in X1.
apply X1.
- apply ileaf in X0.
- apply X0.
destruct case_RCase.
apply ILeaf; simpl; intros.
apply H2.
Defined.
- Definition closed2expr : forall c (pn:@ClosedSIND _ Rule c), ITree _ judg2exprType c.
- refine ((
- fix closed2expr' j (pn:@ClosedSIND _ Rule j) {struct pn} : ITree _ judg2exprType j :=
- match pn in @ClosedSIND _ _ J return ITree _ judg2exprType J with
- | cnd_weak => let case_nil := tt in INone _ _
- | cnd_rule h c cnd' r => let case_rule := tt in rule2expr _ _ r (closed2expr' _ cnd')
- | cnd_branch _ _ c1 c2 => let case_branch := tt in IBranch _ _ (closed2expr' _ c1) (closed2expr' _ c2)
- end)); clear closed2expr'; intros; subst.
- Defined.
+ Fixpoint closed2expr h j (pn:@SIND _ Rule h j) {struct pn} : ITree _ judg2exprType h -> ITree _ judg2exprType j :=
+ match pn in @SIND _ _ H J return ITree _ judg2exprType H -> ITree _ judg2exprType J with
+ | scnd_weak _ => let case_nil := tt in fun _ => INone _ _
+ | scnd_comp x h c cnd' r => let case_rule := tt in fun q => rule2expr _ _ r (closed2expr _ _ cnd' q)
+ | scnd_branch _ _ _ c1 c2 => let case_branch := tt in fun q => IBranch _ _ (closed2expr _ _ c1 q) (closed2expr _ _ c2 q)
+ end.
- Lemma manyFresh : forall Γ Σ (ξ0:VV -> LeveledHaskType Γ ★),
- FreshM { vars : _ & { ξ : VV -> LeveledHaskType Γ ★ & Σ = mapOptionTree ξ vars } }.
- intros Γ Σ.
- induction Σ; intro ξ.
- destruct a.
- destruct l as [τ l].
- set (fresh_lemma' Γ [τ] [] [] ξ l (refl_equal _)) as q.
- refine (q >>>= fun q' => return _).
- apply FreshMon.
- clear q.
- destruct q' as [varstypes [pf1 [pf2 distpf]]].
- exists (mapOptionTree (@fst _ _) varstypes).
- exists (update_ξ ξ l (leaves varstypes)).
- symmetry; auto.
- refine (return _).
- exists [].
- exists ξ; auto.
- refine (bind f1 = IHΣ1 ξ ; _).
- apply FreshMon.
- destruct f1 as [vars1 [ξ1 pf1]].
- refine (bind f2 = IHΣ2 ξ1 ; _).
- apply FreshMon.
- destruct f2 as [vars2 [ξ2 pf22]].
- refine (return _).
- exists (vars1,,vars2).
- exists ξ2.
- simpl.
- rewrite pf22.
- rewrite pf1.
- admit.
- Defined.
-
- Definition proof2expr Γ Δ τ Σ (ξ0: VV -> LeveledHaskType Γ ★)
- {zz:ToString VV} : ND Rule [] [Γ > Δ > Σ |- [τ]] ->
- FreshM (???{ ξ : _ & Expr Γ Δ ξ τ}).
+ Definition proof2expr Γ Δ τ l Σ (ξ0: VV -> LeveledHaskType Γ ★)
+ {zz:ToString VV} : ND Rule [] [Γ > Δ > Σ |- [τ] @ l] ->
+ FreshM (???{ ξ : _ & Expr Γ Δ ξ τ l}).
intro pf.
- set (closedFromSIND _ _ (mkSIND systemfc_all_rules_one_conclusion _ _ _ pf (scnd_weak [])) cnd_weak) as cnd.
+ set (mkSIND systemfc_all_rules_one_conclusion _ _ _ pf (scnd_weak [])) as cnd.
apply closed2expr in cnd.
apply ileaf in cnd.
simpl in *.
auto.
refine (return OK _).
exists ξ.
- apply (ileaf it).
+ apply ileaf in it.
+ simpl in it.
+ apply it.
+ apply INone.
Defined.
End HaskProofToStrong.
--- /dev/null
+(*********************************************************************************************************************************)
+(* HaskSkolemizer: *)
+(* *)
+(* Skolemizes the portion of a proof which uses judgments at level >0 *)
+(* *)
+(*********************************************************************************************************************************)
+
+Generalizable All Variables.
+Require Import Preamble.
+Require Import General.
+Require Import NaturalDeduction.
+Require Import NaturalDeductionContext.
+Require Import Coq.Strings.String.
+Require Import Coq.Lists.List.
+
+Require Import HaskKinds.
+Require Import HaskCoreTypes.
+Require Import HaskCoreVars.
+Require Import HaskWeakTypes.
+Require Import HaskWeakVars.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
+Require Import HaskStrongTypes.
+Require Import HaskProof.
+Require Import NaturalDeduction.
+
+Require Import HaskStrongTypes.
+Require Import HaskStrong.
+Require Import HaskProof.
+Require Import HaskStrongToProof.
+Require Import HaskProofToStrong.
+Require Import HaskWeakToStrong.
+
+Open Scope nd_scope.
+Set Printing Width 130.
+
+Section HaskSkolemizer.
+
+(*
+ Fixpoint debruijn2phoas {κ} (exp: RawHaskType (fun _ => nat) κ) : HaskType TV κ :=
+ match exp with
+ | TVar _ x => x
+ | TAll _ y => TAll _ (fun v => debruijn2phoas (y (TVar v)))
+ | TApp _ _ x y => TApp (debruijn2phoas x) (debruijn2phoas y)
+ | TCon tc => TCon tc
+ | TCoerc _ t1 t2 t => TCoerc (debruijn2phoas t1) (debruijn2phoas t2) (debruijn2phoas t)
+ | TArrow => TArrow
+ | TCode v e => TCode (debruijn2phoas v) (debruijn2phoas e)
+ | TyFunApp tfc kl k lt => TyFunApp tfc kl k (debruijn2phoasyFunApp _ lt)
+ end
+ with debruijn2phoasyFunApp (lk:list Kind)(exp:@RawHaskTypeList (fun _ => nat) lk) : @HaskTypeList TV lk :=
+ match exp in @RawHaskTypeList _ LK return @RawHaskTypeList TV LK with
+ | TyFunApp_nil => TyFunApp_nil
+ | TyFunApp_cons κ kl t rest => TyFunApp_cons _ _ (debruijn2phoas t) (debruijn2phoasyFunApp _ rest)
+ end.
+*)
+ Definition isNotBrakOrEsc {h}{c} (r:Rule h c) : Prop :=
+ match r with
+ | RBrak _ _ _ _ _ _ => False
+ | REsc _ _ _ _ _ _ => False
+ | _ => True
+ end.
+
+ Fixpoint mkArrows {Γ}(lt:list (HaskType Γ ★))(t:HaskType Γ ★) : HaskType Γ ★ :=
+ match lt with
+ | nil => t
+ | a::b => mkArrows b (a ---> t)
+ end.
+
+(*
+ Fixpoint unleaves_ {Γ}(t:Tree ??(LeveledHaskType Γ ★))(l:list (HaskType Γ ★)) lev : Tree ??(LeveledHaskType Γ ★) :=
+ match l with
+ | nil => t
+ | a::b => unleaves_ (t,,[a @@ lev]) b lev
+ end.
+*)
+ (* weak inverse of "leaves" *)
+ Fixpoint unleaves_ {A:Type}(l:list A) : Tree (option A) :=
+ match l with
+ | nil => []
+ | (a::nil) => [a]
+ | (a::b) => [a],,(unleaves_ b)
+ end.
+
+ (* rules of skolemized proofs *)
+ Definition getΓ (j:Judg) := match j with Γ > _ > _ |- _ @ _ => Γ end.
+
+ Fixpoint take_trustme {Γ}
+ (n:nat)
+ (l:forall TV, InstantiatedTypeEnv TV Γ -> list (RawHaskType TV ★))
+ : list (HaskType Γ ★) :=
+
+ match n with
+ | 0 => nil
+ | S n' => (fun TV ite => match l TV ite with
+ | nil => Prelude_error "impossible"
+ | a::b => a
+ end)
+ ::
+ take_trustme n' (fun TV ite => match l TV ite with
+ | nil => Prelude_error "impossible"
+ | a::b => b
+ end)
+ end.
+
+ Axiom phoas_extensionality : forall Γ Q (f g:forall TV, InstantiatedTypeEnv TV Γ -> Q TV),
+ (forall tv ite, f tv ite = g tv ite) -> f=g.
+
+ Definition take_arg_types_as_tree {Γ}(ht:HaskType Γ ★) : Tree ??(HaskType Γ ★ ) :=
+ unleaves_
+ (take_trustme
+ (count_arg_types (ht _ (ite_unit _)))
+ (fun TV ite => take_arg_types (ht TV ite))).
+
+ Definition drop_arg_types_as_tree {Γ} (ht:HaskType Γ ★) : HaskType Γ ★ :=
+ fun TV ite => drop_arg_types (ht TV ite).
+
+ Implicit Arguments take_arg_types_as_tree [[Γ]].
+ Implicit Arguments drop_arg_types_as_tree [[Γ]].
+
+ Definition take_arrange : forall {Γ} (tx te:HaskType Γ ★) lev,
+ Arrange ([tx @@ lev],,take_arg_types_as_tree te @@@ lev)
+ (take_arg_types_as_tree (tx ---> te) @@@ lev).
+ intros.
+ destruct (eqd_dec ([tx],,take_arg_types_as_tree te) (take_arg_types_as_tree (tx ---> te))).
+ rewrite <- e.
+ simpl.
+ apply AId.
+ unfold take_arg_types_as_tree.
+ Opaque take_arg_types_as_tree.
+ simpl.
+ destruct (count_arg_types (te (fun _ : Kind => unit) (ite_unit Γ))).
+ simpl.
+ replace (tx) with (fun (TV : Kind → Type) (ite : InstantiatedTypeEnv TV Γ) => tx TV ite).
+ apply ACanR.
+ apply phoas_extensionality.
+ reflexivity.
+ apply (Prelude_error "should not be possible").
+ Defined.
+ Transparent take_arg_types_as_tree.
+
+ Definition take_unarrange : forall {Γ} (tx te:HaskType Γ ★) lev,
+ Arrange (take_arg_types_as_tree (tx ---> te) @@@ lev)
+ ([tx @@ lev],,take_arg_types_as_tree te @@@ lev).
+ intros.
+ destruct (eqd_dec ([tx],,take_arg_types_as_tree te) (take_arg_types_as_tree (tx ---> te))).
+ rewrite <- e.
+ simpl.
+ apply AId.
+ unfold take_arg_types_as_tree.
+ Opaque take_arg_types_as_tree.
+ simpl.
+ destruct (count_arg_types (te (fun _ : Kind => unit) (ite_unit Γ))).
+ simpl.
+ replace (tx) with (fun (TV : Kind → Type) (ite : InstantiatedTypeEnv TV Γ) => tx TV ite).
+ apply AuCanR.
+ apply phoas_extensionality.
+ reflexivity.
+ apply (Prelude_error "should not be possible").
+ Defined.
+ Transparent take_arg_types_as_tree.
+
+ Lemma drop_works : forall {Γ}(t1 t2:HaskType Γ ★),
+ drop_arg_types_as_tree (t1 ---> t2) = (drop_arg_types_as_tree t2).
+ intros.
+ unfold drop_arg_types_as_tree.
+ simpl.
+ reflexivity.
+ Qed.
+
+ Inductive SRule : Tree ??Judg -> Tree ??Judg -> Type :=
+(* | SFlat : forall h c (r:Rule h c), isNotBrakOrEsc r -> SRule h c*)
+ | SFlat : forall h c, Rule h c -> SRule h c
+ | SBrak : forall Γ Δ t ec Σ l,
+ SRule
+ [Γ > Δ > Σ,,(take_arg_types_as_tree t @@@ (ec::l)) |- [ drop_arg_types_as_tree t ] @ (ec::l)]
+ [Γ > Δ > Σ |- [<[ec |- t]> ] @l]
+
+ | SEsc : forall Γ Δ t ec Σ l,
+ SRule
+ [Γ > Δ > Σ |- [<[ec |- t]> ] @l]
+ [Γ > Δ > Σ,,(take_arg_types_as_tree t @@@ (ec::l)) |- [ drop_arg_types_as_tree t ] @ (ec::l)]
+ .
+
+ Definition take_arg_types_as_tree' {Γ}(lt:LeveledHaskType Γ ★) :=
+ match lt with t @@ l => take_arg_types_as_tree t @@@ l end.
+
+ Definition drop_arg_types_as_tree' {Γ}(lt:LeveledHaskType Γ ★) :=
+ match lt with t @@ l => drop_arg_types_as_tree t @@ l end.
+
+ Definition skolemize_judgment (j:Judg) : Judg :=
+ match j with
+ | Γ > Δ > Σ₁ |- Σ₂ @ nil => j
+ | Γ > Δ > Σ₁ |- Σ₂ @ lev =>
+ Γ > Δ > Σ₁,,(mapOptionTreeAndFlatten take_arg_types_as_tree Σ₂ @@@ lev) |- mapOptionTree drop_arg_types_as_tree Σ₂ @ lev
+ end.
+
+ Definition check_hof : forall {Γ}(t:HaskType Γ ★),
+ sumbool
+ True
+ (take_arg_types_as_tree t = [] /\ drop_arg_types_as_tree t = t).
+ intros.
+ destruct (eqd_dec (take_arg_types_as_tree t) []);
+ destruct (eqd_dec (drop_arg_types_as_tree t) t).
+ right; auto.
+ left; auto.
+ left; auto.
+ left; auto.
+ Defined.
+
+ Opaque take_arg_types_as_tree.
+ Definition skolemize_proof :
+ forall {h}{c},
+ ND Rule h c ->
+ ND SRule (mapOptionTree skolemize_judgment h) (mapOptionTree skolemize_judgment c).
+ intros.
+ eapply nd_map'; [ idtac | apply X ].
+ clear h c X.
+ intros.
+
+ refine (match X as R in Rule H C with
+ | RArrange Γ Δ a b x l d => let case_RArrange := tt in _
+ | RNote Γ Δ Σ τ l n => let case_RNote := tt in _
+ | RLit Γ Δ l _ => let case_RLit := tt in _
+ | RVar Γ Δ σ lev => let case_RVar := tt in _
+ | RGlobal Γ Δ σ l wev => let case_RGlobal := tt in _
+ | RLam Γ Δ Σ tx te lev => let case_RLam := tt in _
+ | RCast Γ Δ Σ σ τ lev γ => let case_RCast := tt in _
+ | RAbsT Γ Δ Σ κ σ lev n => let case_RAbsT := tt in _
+ | RAppT Γ Δ Σ κ σ τ lev => let case_RAppT := tt in _
+ | RAppCo Γ Δ Σ κ σ₁ σ₂ γ σ lev => let case_RAppCo := tt in _
+ | RAbsCo Γ Δ Σ κ σ σ₁ σ₂ lev => let case_RAbsCo := tt in _
+ | RApp Γ Δ Σ₁ Σ₂ tx te lev => let case_RApp := tt in _
+ | RCut Γ Δ Σ Σ₁ Σ₁₂ Σ₂ Σ₃ l => let case_RCut := tt in _
+ | RLeft Γ Δ Σ₁ Σ₂ Σ l => let case_RLeft := tt in _
+ | RRight Γ Δ Σ₁ Σ₂ Σ l => let case_RRight := tt in _
+ | RVoid _ _ l => let case_RVoid := tt in _
+ | RBrak Γ Δ t ec succ lev => let case_RBrak := tt in _
+ | REsc Γ Δ t ec succ lev => let case_REsc := tt in _
+ | RCase Γ Δ lev tc Σ avars tbranches alts => let case_RCase := tt in _
+ | RLetRec Γ Δ lri x y t => let case_RLetRec := tt in _
+ end); clear X h c.
+
+ destruct case_RArrange.
+ simpl.
+ destruct l.
+ apply nd_rule.
+ apply SFlat.
+ apply RArrange.
+ apply d.
+ apply nd_rule.
+ apply SFlat.
+ apply RArrange.
+ apply ARight.
+ apply d.
+
+ destruct case_RBrak.
+ simpl.
+ destruct lev; [ idtac | apply (Prelude_error "Brak with nesting depth >1") ].
+ apply nd_rule.
+ apply SBrak.
+
+ destruct case_REsc.
+ simpl.
+ destruct lev; [ idtac | apply (Prelude_error "Esc with nesting depth >1") ].
+ apply nd_rule.
+ apply SEsc.
+
+ destruct case_RNote.
+ apply nd_rule.
+ apply SFlat.
+ simpl.
+ destruct l.
+ apply RNote.
+ apply n.
+ apply RNote.
+ apply n.
+
+ destruct case_RLit.
+ simpl.
+ destruct l0.
+ apply nd_rule.
+ apply SFlat.
+ apply RLit.
+ set (check_hof (@literalType l Γ)) as hof.
+ destruct hof; [ apply (Prelude_error "attempt to use a literal with higher-order type at depth>0") | idtac ].
+ destruct a.
+ rewrite H.
+ rewrite H0.
+ simpl.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply SFlat; eapply RArrange; apply AuCanL ].
+ apply nd_rule.
+ apply SFlat.
+ apply RLit.
+
+ destruct case_RVar.
+ simpl.
+ destruct lev.
+ apply nd_rule; apply SFlat; apply RVar.
+ set (check_hof σ) as hof.
+ destruct hof; [ apply (Prelude_error "attempt to use a variable with higher-order type at depth>0") | idtac ].
+ destruct a.
+ rewrite H.
+ rewrite H0.
+ simpl.
+ eapply nd_comp; [ idtac | eapply nd_rule; apply SFlat; eapply RArrange; apply AuCanR ].
+ apply nd_rule.
+ apply SFlat.
+ apply RVar.
+
+ destruct case_RGlobal.
+ simpl.
+ destruct σ.
+ apply nd_rule; apply SFlat; apply RGlobal.
+ set (check_hof (l wev)) as hof.
+ destruct hof; [ apply (Prelude_error "attempt to use a global with higher-order type at depth>0") | idtac ].
+ destruct a.
+ rewrite H.
+ rewrite H0.
+ simpl.
+ eapply nd_comp; [ idtac | eapply nd_rule; apply SFlat; eapply RArrange; apply AuCanR ].
+ apply nd_rule.
+ apply SFlat.
+ apply RGlobal.
+
+ destruct case_RLam.
+ destruct lev.
+ apply nd_rule.
+ apply SFlat.
+ simpl.
+ apply RLam.
+ simpl.
+ rewrite drop_works.
+ apply nd_rule.
+ apply SFlat.
+ apply RArrange.
+ eapply AComp.
+ eapply AuAssoc.
+ eapply ALeft.
+ apply take_arrange.
+
+ destruct case_RCast.
+ simpl.
+ destruct lev.
+ apply nd_rule.
+ apply SFlat.
+ apply RCast.
+ apply γ.
+ apply (Prelude_error "found RCast at level >0").
+
+ destruct case_RApp.
+ simpl.
+ destruct lev.
+ apply nd_rule.
+ apply SFlat.
+ apply RApp.
+ rewrite drop_works.
+ set (check_hof tx) as hof_tx.
+ destruct hof_tx; [ apply (Prelude_error "attempt tp apply a higher-order function at depth>0") | idtac ].
+ destruct a.
+ rewrite H.
+ rewrite H0.
+ simpl.
+ eapply nd_comp.
+ eapply nd_prod; [ idtac | eapply nd_rule; eapply SFlat; eapply RArrange; eapply ACanR ].
+ eapply nd_rule.
+ eapply SFlat.
+ eapply RArrange.
+ eapply ALeft.
+ eapply take_unarrange.
+
+ eapply nd_comp; [ idtac | eapply nd_rule; apply SFlat; eapply RArrange; apply AAssoc ].
+ eapply nd_comp; [ apply nd_exch | idtac ].
+ eapply nd_rule; eapply SFlat; eapply RCut.
+
+ destruct case_RCut.
+ simpl; destruct l; [ apply nd_rule; apply SFlat; apply RCut | idtac ].
+ set (mapOptionTreeAndFlatten take_arg_types_as_tree Σ₃) as Σ₃''.
+ set (mapOptionTree drop_arg_types_as_tree Σ₃) as Σ₃'''.
+ set (mapOptionTreeAndFlatten take_arg_types_as_tree Σ₁₂) as Σ₁₂''.
+ set (mapOptionTree drop_arg_types_as_tree Σ₁₂) as Σ₁₂'''.
+ destruct (decide_tree_empty (Σ₁₂'' @@@ (h::l)));
+ [ idtac | apply (Prelude_error "used RCut on a variable with function type") ].
+ destruct (eqd_dec Σ₁₂ Σ₁₂'''); [ idtac | apply (Prelude_error "used RCut on a variable with function type") ].
+ rewrite <- e.
+ clear e.
+ destruct s.
+ eapply nd_comp.
+ eapply nd_prod.
+ eapply nd_rule.
+ eapply SFlat.
+ eapply RArrange.
+ eapply AComp.
+ eapply ALeft.
+ eapply arrangeCancelEmptyTree with (q:=x).
+ apply e.
+ apply ACanR.
+ apply nd_id.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply SFlat; eapply RArrange; eapply AAssoc ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply SFlat; eapply RArrange; eapply ALeft; eapply AAssoc ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply SFlat; eapply RCut ].
+ apply nd_prod.
+ apply nd_id.
+ eapply nd_rule.
+ eapply SFlat.
+ eapply RArrange.
+ eapply AComp.
+ eapply AuAssoc.
+ eapply ALeft.
+ eapply AComp.
+ eapply AuAssoc.
+ eapply ALeft.
+ eapply AId.
+
+ destruct case_RLeft.
+ simpl; destruct l; [ apply nd_rule; apply SFlat; apply RLeft | idtac ].
+ set (mapOptionTreeAndFlatten take_arg_types_as_tree Σ₂) as Σ₂'.
+ set (mapOptionTreeAndFlatten take_arg_types_as_tree Σ) as Σ'.
+ set (mapOptionTree drop_arg_types_as_tree Σ₂) as Σ₂''.
+ set (mapOptionTree drop_arg_types_as_tree Σ) as Σ''.
+ destruct (decide_tree_empty (Σ' @@@ (h::l)));
+ [ idtac | apply (Prelude_error "used RLeft on a variable with function type") ].
+ destruct (eqd_dec Σ Σ''); [ idtac | apply (Prelude_error "used RLeft on a variable with function type") ].
+ rewrite <- e.
+ clear Σ'' e.
+ destruct s.
+ set (arrangeUnCancelEmptyTree _ _ e) as q.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply SFlat; eapply RArrange; eapply ALeft; eapply ARight; eapply q ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply SFlat; eapply RArrange; eapply ALeft; eapply AuCanL; eapply q ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply SFlat; eapply RArrange; eapply AAssoc ].
+ apply nd_rule.
+ eapply SFlat.
+ eapply RLeft.
+
+ destruct case_RRight.
+ simpl; destruct l; [ apply nd_rule; apply SFlat; apply RRight | idtac ].
+ set (mapOptionTreeAndFlatten take_arg_types_as_tree Σ₂) as Σ₂'.
+ set (mapOptionTreeAndFlatten take_arg_types_as_tree Σ) as Σ'.
+ set (mapOptionTree drop_arg_types_as_tree Σ₂) as Σ₂''.
+ set (mapOptionTree drop_arg_types_as_tree Σ) as Σ''.
+ destruct (decide_tree_empty (Σ' @@@ (h::l)));
+ [ idtac | apply (Prelude_error "used RRight on a variable with function type") ].
+ destruct (eqd_dec Σ Σ''); [ idtac | apply (Prelude_error "used RRight on a variable with function type") ].
+ rewrite <- e.
+ clear Σ'' e.
+ destruct s.
+ set (arrangeUnCancelEmptyTree _ _ e) as q.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply SFlat; eapply RArrange; eapply ALeft; eapply ALeft; eapply q ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply SFlat; eapply RArrange; eapply ALeft; eapply AuCanR ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply SFlat; eapply RArrange; eapply AAssoc ].
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply SFlat; eapply RArrange; eapply ALeft; eapply AExch ]. (* yuck *)
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply SFlat; eapply RArrange; eapply AuAssoc ].
+ eapply nd_rule.
+ eapply SFlat.
+ apply RRight.
+
+ destruct case_RVoid.
+ simpl.
+ destruct l.
+ apply nd_rule.
+ apply SFlat.
+ apply RVoid.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply SFlat; eapply RArrange; eapply AuCanL ].
+ apply nd_rule.
+ apply SFlat.
+ apply RVoid.
+
+ destruct case_RAppT.
+ simpl.
+ destruct lev; [ apply nd_rule; apply SFlat; apply RAppT | idtac ].
+ apply (Prelude_error "RAppT at depth>0").
+
+ destruct case_RAbsT.
+ simpl.
+ destruct lev; simpl.
+ apply nd_rule.
+ apply SFlat.
+ apply (@RAbsT Γ Δ Σ κ σ nil n).
+ apply (Prelude_error "RAbsT at depth>0").
+
+ destruct case_RAppCo.
+ simpl.
+ destruct lev; [ apply nd_rule; apply SFlat; apply RAppCo | idtac ].
+ apply γ.
+ apply (Prelude_error "RAppCo at depth>0").
+
+ destruct case_RAbsCo.
+ simpl.
+ destruct lev; [ apply nd_rule; apply SFlat; apply RAbsCo | idtac ].
+ apply (Prelude_error "RAbsCo at depth>0").
+
+ destruct case_RLetRec.
+ simpl.
+ destruct t.
+ apply nd_rule.
+ apply SFlat.
+ apply (@RLetRec Γ Δ lri x y nil).
+ destruct (decide_tree_empty (mapOptionTreeAndFlatten take_arg_types_as_tree y @@@ (h :: t)));
+ [ idtac | apply (Prelude_error "used LetRec on a set of bindings involving a function type") ].
+ destruct (eqd_dec y (mapOptionTree drop_arg_types_as_tree y));
+ [ idtac | apply (Prelude_error "used LetRec on a set of bindings involving a function type") ].
+ rewrite <- e.
+ clear e.
+ eapply nd_comp.
+ eapply nd_rule.
+ eapply SFlat.
+ eapply RArrange.
+ eapply ALeft.
+ eapply AComp.
+ eapply ARight.
+ destruct s.
+ apply (arrangeCancelEmptyTree _ _ e).
+ apply ACanL.
+ eapply nd_comp.
+ eapply nd_rule.
+ eapply SFlat.
+ eapply RArrange.
+ eapply AuAssoc.
+ eapply nd_rule.
+ eapply SFlat.
+ eapply RLetRec.
+
+ destruct case_RCase.
+ destruct lev; [ idtac | apply (Prelude_error "case at depth >0") ]; simpl.
+ apply nd_rule.
+ apply SFlat.
+ rewrite <- mapOptionTree_compose.
+ assert
+ ((mapOptionTree (fun x => skolemize_judgment (@pcb_judg tc Γ Δ nil tbranches avars (fst x) (snd x))) alts) =
+ (mapOptionTree (fun x => (@pcb_judg tc Γ Δ nil tbranches avars (fst x) (snd x))) alts)).
+ admit.
+ rewrite H.
+ set (@RCase Γ Δ nil tc Σ avars tbranches alts) as q.
+ apply q.
+ Defined.
+
+ Transparent take_arg_types_as_tree.
+
+End HaskSkolemizer.
Require Import Coq.Lists.List.
Require Import HaskKinds.
Require Import HaskCoreTypes.
-Require Import HaskLiteralsAndTyCons.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
Require Import HaskStrongTypes.
Require Import HaskWeakVars.
+Require Import HaskCoreToWeak.
Require Import HaskCoreVars.
Section HaskStrong.
{ scbwv_exprvars : vec VV (sac_numExprVars sac)
; scbwv_exprvars_distinct : distinct (vec2list scbwv_exprvars)
; scbwv_varstypes := vec_zip scbwv_exprvars (sac_types sac Γ atypes)
- ; scbwv_ξ := fun ξ lev => update_ξ (weakLT'○ξ) (weakL' lev) (vec2list scbwv_varstypes)
+ ; scbwv_xi := fun ξ lev => update_xi (weakLT'○ξ) (weakL' lev) (vec2list scbwv_varstypes)
}.
Implicit Arguments StrongCaseBranchWithVVs [[Γ]].
- Inductive Expr : forall Γ (Δ:CoercionEnv Γ), (VV -> LeveledHaskType Γ ★) -> LeveledHaskType Γ ★ -> Type :=
+ Inductive Expr : forall Γ (Δ:CoercionEnv Γ), (VV -> LeveledHaskType Γ ★) -> HaskType Γ ★ -> HaskLevel Γ -> Type :=
(* an "EGlobal" is any variable which is free in the expression which was passed to -fcoqpass (ie bound outside it) *)
- | EGlobal: ∀ Γ Δ ξ t, WeakExprVar -> Expr Γ Δ ξ t
+ | EGlobal: forall Γ Δ ξ (g:Global Γ) v lev, Expr Γ Δ ξ (g v) lev
- | EVar : ∀ Γ Δ ξ ev, Expr Γ Δ ξ (ξ ev)
- | ELit : ∀ Γ Δ ξ lit l, Expr Γ Δ ξ (literalType lit@@l)
- | EApp : ∀ Γ Δ ξ t1 t2 l, Expr Γ Δ ξ (t2--->t1 @@ l) -> Expr Γ Δ ξ (t2 @@ l) -> Expr Γ Δ ξ (t1 @@ l)
- | ELam : ∀ Γ Δ ξ t1 t2 l ev, Expr Γ Δ (update_ξ ξ l ((ev,t1)::nil)) (t2@@l) -> Expr Γ Δ ξ (t1--->t2@@l)
- | ELet : ∀ Γ Δ ξ tv t l ev,Expr Γ Δ ξ (tv@@l)->Expr Γ Δ (update_ξ ξ l ((ev,tv)::nil))(t@@l) -> Expr Γ Δ ξ (t@@l)
- | EEsc : ∀ Γ Δ ξ ec t l, Expr Γ Δ ξ (<[ ec |- t ]> @@ l) -> Expr Γ Δ ξ (t @@ (ec::l))
- | EBrak : ∀ Γ Δ ξ ec t l, Expr Γ Δ ξ (t @@ (ec::l)) -> Expr Γ Δ ξ (<[ ec |- t ]> @@ l)
- | ECast : forall Γ Δ ξ t1 t2 (γ:HaskCoercion Γ Δ (t1 ∼∼∼ t2)) l,
- Expr Γ Δ ξ (t1 @@ l) -> Expr Γ Δ ξ (t2 @@ l)
- | ENote : ∀ Γ Δ ξ t, Note -> Expr Γ Δ ξ t -> Expr Γ Δ ξ t
- | ETyApp : ∀ Γ Δ κ σ τ ξ l, Expr Γ Δ ξ (HaskTAll κ σ @@ l) -> Expr Γ Δ ξ (substT σ τ @@ l)
- | ECoLam : forall Γ Δ κ σ (σ₁ σ₂:HaskType Γ κ) ξ l,
- Expr Γ (σ₁∼∼∼σ₂::Δ) ξ (σ @@ l) -> Expr Γ Δ ξ (σ₁∼∼σ₂ ⇒ σ @@ l)
- | ECoApp : forall Γ Δ κ (σ₁ σ₂:HaskType Γ κ) (γ:HaskCoercion Γ Δ (σ₁∼∼∼σ₂)) σ ξ l,
- Expr Γ Δ ξ (σ₁ ∼∼ σ₂ ⇒ σ @@ l) -> Expr Γ Δ ξ (σ @@l)
- | ETyLam : ∀ Γ Δ ξ κ σ l,
- Expr (κ::Γ) (weakCE Δ) (weakLT○ξ) (HaskTApp (weakF σ) (FreshHaskTyVar _)@@(weakL l))-> Expr Γ Δ ξ (HaskTAll κ σ @@ l)
+ | EVar : ∀ Γ Δ ξ ev, Expr Γ Δ ξ (unlev (ξ ev)) (getlev (ξ ev))
+ | ELit : ∀ Γ Δ ξ lit l, Expr Γ Δ ξ (literalType lit) l
+ | EApp : ∀ Γ Δ ξ t1 t2 l, Expr Γ Δ ξ (t2--->t1) l -> Expr Γ Δ ξ t2 l -> Expr Γ Δ ξ (t1) l
+ | ELam : ∀ Γ Δ ξ t1 t2 l ev, Expr Γ Δ (update_xi ξ l ((ev,t1)::nil)) t2 l -> Expr Γ Δ ξ (t1--->t2) l
+ | ELet : ∀ Γ Δ ξ tv t l ev,Expr Γ Δ ξ tv l ->Expr Γ Δ (update_xi ξ l ((ev,tv)::nil)) t l -> Expr Γ Δ ξ t l
+ | EEsc : ∀ Γ Δ ξ ec t l, Expr Γ Δ ξ (<[ ec |- t ]>) l -> Expr Γ Δ ξ t (ec::l)
+ | EBrak : ∀ Γ Δ ξ ec t l, Expr Γ Δ ξ t (ec::l) -> Expr Γ Δ ξ (<[ ec |- t ]>) l
+ | ECast : forall Γ Δ ξ t1 t2 (γ:HaskCoercion Γ Δ (t1 ∼∼∼ t2)) l, Expr Γ Δ ξ t1 l -> Expr Γ Δ ξ t2 l
+ | ENote : ∀ Γ Δ ξ t l, Note -> Expr Γ Δ ξ t l -> Expr Γ Δ ξ t l
+ | ETyApp : ∀ Γ Δ κ σ τ ξ l, Expr Γ Δ ξ (HaskTAll κ σ) l -> Expr Γ Δ ξ (substT σ τ) l
+ | ECoLam : forall Γ Δ κ σ (σ₁ σ₂:HaskType Γ κ) ξ l, Expr Γ (σ₁∼∼∼σ₂::Δ) ξ σ l -> Expr Γ Δ ξ (σ₁∼∼σ₂ ⇒ σ) l
+ | ECoApp : forall Γ Δ κ (σ₁ σ₂:HaskType Γ κ) (γ:HaskCoercion Γ Δ (σ₁∼∼∼σ₂)) σ ξ l, Expr Γ Δ ξ (σ₁ ∼∼ σ₂ ⇒ σ) l -> Expr Γ Δ ξ σ l
+ | ETyLam : ∀ Γ Δ ξ κ σ l n,
+ Expr (list_ins n κ Γ) (weakCE_ Δ) (weakLT_○ξ) (HaskTApp (weakF_ σ) (FreshHaskTyVar_ _)) (weakL_ l)-> Expr Γ Δ ξ (HaskTAll κ σ) l
| ECase : forall Γ Δ ξ l tc tbranches atypes,
- Expr Γ Δ ξ (caseType tc atypes @@ l) ->
+ Expr Γ Δ ξ (caseType tc atypes) l ->
Tree ??{ sac : _
& { scb : StrongCaseBranchWithVVs tc atypes sac
- & Expr (sac_Γ sac Γ)
- (sac_Δ sac Γ atypes (weakCK'' Δ))
- (scbwv_ξ scb ξ l)
- (weakLT' (tbranches@@l)) } } ->
- Expr Γ Δ ξ (tbranches @@ l)
+ & Expr (sac_gamma sac Γ)
+ (sac_delta sac Γ atypes (weakCK'' Δ))
+ (scbwv_xi scb ξ l)
+ (weakT' tbranches)
+ (weakL' l) } } ->
+ Expr Γ Δ ξ tbranches l
| ELetRec : ∀ Γ Δ ξ l τ vars,
- let ξ' := update_ξ ξ l (leaves vars) in
- ELetRecBindings Γ Δ ξ' l vars ->
- Expr Γ Δ ξ' (τ@@l) ->
- Expr Γ Δ ξ (τ@@l)
+ distinct (leaves (mapOptionTree (@fst _ _) vars)) ->
+ let ξ' := update_xi ξ l (leaves vars) in
+ ELetRecBindings Γ Δ ξ' l vars ->
+ Expr Γ Δ ξ' τ l ->
+ Expr Γ Δ ξ τ l
(* can't avoid having an additional inductive: it is a tree of Expr's, each of whose ξ depends on the type of the entire tree *)
with ELetRecBindings : ∀ Γ, CoercionEnv Γ -> (VV -> LeveledHaskType Γ ★) -> HaskLevel Γ -> Tree ??(VV*HaskType Γ ★) -> Type :=
| ELR_nil : ∀ Γ Δ ξ l , ELetRecBindings Γ Δ ξ l []
- | ELR_leaf : ∀ Γ Δ ξ l v t, Expr Γ Δ ξ (t @@ l) -> ELetRecBindings Γ Δ ξ l [(v,t)]
+ | ELR_leaf : ∀ Γ Δ ξ l v t, Expr Γ Δ ξ t l -> ELetRecBindings Γ Δ ξ l [(v,t)]
| ELR_branch : ∀ Γ Δ ξ l t1 t2, ELetRecBindings Γ Δ ξ l t1 -> ELetRecBindings Γ Δ ξ l t2 -> ELetRecBindings Γ Δ ξ l (t1,,t2)
.
Context {ToStringVV:ToString VV}.
Context {ToLatexVV:ToLatex VV}.
- Fixpoint exprToString {Γ}{Δ}{ξ}{τ}(exp:Expr Γ Δ ξ τ) : string :=
+ Fixpoint exprToString {Γ}{Δ}{ξ}{τ}{l}(exp:Expr Γ Δ ξ τ l) : string :=
match exp with
| EVar Γ' _ ξ' ev => "var."+++ toString ev
- | EGlobal Γ' _ ξ' t wev => "global." +++ toString (wev:CoreVar)
+ | EGlobal Γ' _ ξ' g v _ => "global." +++ toString (g:CoreVar)
| ELam Γ' _ _ tv _ _ cv e => "\("+++ toString cv +++":t) -> "+++ exprToString e
| ELet Γ' _ _ t _ _ ev e1 e2 => "let "+++toString ev+++" = "+++exprToString e1+++" in "+++exprToString e2
| ELit _ _ _ lit _ => "lit."+++toString lit
| EApp Γ' _ _ _ _ _ e1 e2 => "("+++exprToString e1+++")("+++exprToString e2+++")"
| EEsc Γ' _ _ ec t _ e => "~~("+++exprToString e+++")"
| EBrak Γ' _ _ ec t _ e => "<["+++exprToString e+++"]>"
- | ENote _ _ _ _ n e => "note."+++exprToString e
+ | ENote _ _ _ _ n _ e => "note."+++exprToString e
| ETyApp Γ Δ κ σ τ ξ l e => "("+++exprToString e+++")@("+++toString τ+++")"
| ECoApp Γ Δ κ σ₁ σ₂ γ σ ξ l e => "("+++exprToString e+++")~(co)"
| ECast Γ Δ ξ t1 t2 γ l e => "cast ("+++exprToString e+++"):t2"
- | ETyLam _ _ _ k _ _ e => "\@_ ->"+++ exprToString e
+ | ETyLam _ _ _ k _ _ _ e => "\@_ ->"+++ exprToString e
| ECoLam Γ Δ κ σ σ₁ σ₂ ξ l e => "\~_ ->"+++ exprToString e
- | ECase Γ Δ ξ l tc tbranches atypes escrut alts => "case " +++ exprToString escrut +++ " of FIXME"
- | ELetRec _ _ _ _ _ vars elrb e => "letrec FIXME in " +++ exprToString e
+ | ECase Γ Δ ξ l tc branches atypes escrut alts => "case " +++ exprToString escrut +++ " of FIXME"
+ | ELetRec _ _ _ _ _ vars vu elrb e => "letrec FIXME in " +++ exprToString e
end.
- Instance ExprToString Γ Δ ξ τ : ToString (Expr Γ Δ ξ τ) := { toString := exprToString }.
+ Instance ExprToString Γ Δ ξ τ l : ToString (Expr Γ Δ ξ τ l) := { toString := exprToString }.
End HaskStrong.
Implicit Arguments StrongCaseBranchWithVVs [[Γ]].
Require Import Preamble.
Require Import General.
Require Import NaturalDeduction.
+Require Import NaturalDeductionContext.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Init.Specif.
Require Import HaskProof.
Section HaskStrongToProof.
-
-Definition pivotContext {T} a b c : @Arrange T ((a,,b),,c) ((a,,c),,b) :=
- RComp (RComp (RCossa _ _ _) (RLeft a (RExch c b))) (RAssoc _ _ _).
-
-Definition copyAndPivotContext {T} a b c : @Arrange T ((a,,b),,(c,,b)) ((a,,c),,b).
- eapply RComp; [ idtac | apply (RLeft (a,,c) (RCont b)) ].
- eapply RComp; [ idtac | apply RCossa ].
- eapply RComp; [ idtac | apply (RRight b (pivotContext a b c)) ].
- apply RAssoc.
- Defined.
-
+
Context {VV:Type}{eqd_vv:EqDecidable VV}.
(* maintenance of Xi *)
reflexivity.
Qed.
-Lemma strip_twice_lemma x y t : stripOutVars x (stripOutVars y t) = stripOutVars (app y x) t.
-(*
- induction x.
- simpl.
+Lemma strip_nil_lemma t : stripOutVars nil t = t.
+ induction t; simpl.
+ unfold stripOutVars.
+ destruct a; reflexivity.
+ rewrite <- IHt1 at 2.
+ rewrite <- IHt2 at 2.
+ reflexivity.
+ Qed.
+
+Lemma strip_swap0_lemma : forall a a0 y t,
+ stripOutVars (a :: a0 :: y) t = stripOutVars (a0 :: a :: y) t.
+ intros.
unfold stripOutVars.
- simpl.
- rewrite mapOptionTree'_compose.
induction t.
- destruct a; try reflexivity.
- simpl.
- destruct (dropVar y v); reflexivity.
- simpl.
- rewrite IHt1.
- rewrite IHt2.
- reflexivity.
- rewrite strip_lemma.
- rewrite IHx.
- rewrite <- strip_lemma.
- rewrite app_comm_cons.
- reflexivity.
-*)
- admit.
+ destruct a1; simpl; [ idtac | reflexivity ].
+ destruct (eqd_dec v a); subst.
+ destruct (eqd_dec a a0); subst.
+ reflexivity.
+ reflexivity.
+ destruct (eqd_dec v a0); subst.
+ reflexivity.
+ reflexivity.
+ simpl in *.
+ rewrite IHt1.
+ rewrite IHt2.
+ reflexivity.
+ Qed.
+
+Lemma strip_swap1_lemma : forall a y t,
+ stripOutVars (a :: nil) (stripOutVars y t) =
+ stripOutVars y (stripOutVars (a :: nil) t).
+ intros.
+ induction y.
+ rewrite strip_nil_lemma.
+ rewrite strip_nil_lemma.
+ reflexivity.
+ rewrite (strip_lemma a0 y (stripOutVars (a::nil) t)).
+ rewrite <- IHy.
+ clear IHy.
+ rewrite <- (strip_lemma a y t).
+ rewrite <- strip_lemma.
+ rewrite <- strip_lemma.
+ apply strip_swap0_lemma.
+ Qed.
+
+Lemma strip_swap_lemma : forall x y t, stripOutVars x (stripOutVars y t) = stripOutVars y (stripOutVars x t).
+ intros; induction t.
+ destruct a; simpl.
+
+ induction x.
+ rewrite strip_nil_lemma.
+ rewrite strip_nil_lemma.
+ reflexivity.
+ rewrite strip_lemma.
+ rewrite (strip_lemma a x [v]).
+ rewrite IHx.
+ clear IHx.
+ apply strip_swap1_lemma.
+ reflexivity.
+ unfold stripOutVars in *.
+ simpl.
+ rewrite IHt1.
+ rewrite IHt2.
+ reflexivity.
Qed.
-Lemma strip_distinct a y : (not (In a (leaves y))) -> stripOutVars (a :: nil) y = y.
+Lemma strip_twice_lemma x y t : stripOutVars x (stripOutVars y t) = stripOutVars (app x y) t.
+ induction x; simpl.
+ apply strip_nil_lemma.
+ rewrite strip_lemma.
+ rewrite IHx.
+ clear IHx.
+ rewrite <- strip_lemma.
+ reflexivity.
+ Qed.
+
+Lemma notin_strip_inert a y : (not (In a (leaves y))) -> stripOutVars (a :: nil) y = y.
intros.
induction y.
destruct a0; try reflexivity.
auto.
Qed.
-Lemma strip_distinct' y : forall x, distinct (app x (leaves y)) -> stripOutVars x y = y.
+Lemma notin_strip_inert' y : forall x, distinct (app x (leaves y)) -> stripOutVars x y = y.
induction x; intros.
simpl in H.
unfold stripOutVars.
set (IHx H3) as qq.
rewrite strip_lemma.
rewrite IHx.
- apply strip_distinct.
+ apply notin_strip_inert.
unfold not; intros.
apply H2.
apply In_both'.
auto.
Qed.
+Lemma dropvar_lemma v v' y : dropVar y v = Some v' -> v=v'.
+ intros.
+ induction y; auto.
+ simpl in H.
+ inversion H.
+ auto.
+ apply IHy.
+ simpl in H.
+ destruct (eqd_dec v a).
+ inversion H.
+ auto.
+ Qed.
+
Lemma updating_stripped_tree_is_inert'
{Γ} lev
(ξ:VV -> LeveledHaskType Γ ★)
lv tree2 :
- mapOptionTree (update_ξ ξ lev lv) (stripOutVars (map (@fst _ _) lv) tree2)
+ mapOptionTree (update_xi ξ lev lv) (stripOutVars (map (@fst _ _) lv) tree2)
= mapOptionTree ξ (stripOutVars (map (@fst _ _) lv) tree2).
+
induction tree2.
- destruct a.
- simpl.
- induction lv.
- reflexivity.
- simpl.
- destruct a.
- simpl.
- set (eqd_dec v v0) as q.
- destruct q.
- auto.
- set (dropVar (map (@fst _ _) lv) v) as b in *.
- destruct b.
- inversion IHlv.
- admit.
- auto.
- reflexivity.
+ destruct a; [ idtac | reflexivity ]; simpl.
+ induction lv; [ reflexivity | idtac ]; simpl.
+ destruct a; simpl.
+ set (eqd_dec v v0) as q; destruct q; auto.
+ set (dropVar (map (@fst _ _) lv) v) as b in *.
+ assert (dropVar (map (@fst _ _) lv) v=b). reflexivity.
+ destruct b; [ idtac | reflexivity ].
+ apply dropvar_lemma in H.
+ subst.
+ inversion IHlv.
+ rewrite H0.
+ clear H0 IHlv.
+ destruct (eqd_dec v0 v1).
+ subst.
+ assert False. apply n. intros; auto. inversion H.
+ reflexivity.
+ unfold stripOutVars in *.
+ simpl.
+ rewrite <- IHtree2_1.
+ rewrite <- IHtree2_2.
+ reflexivity.
+ Qed.
+
+Lemma distinct_bogus : forall {T}a0 (a:list T), distinct (a0::(app a (a0::nil))) -> False.
+ intros; induction a; auto.
+ simpl in H.
+ inversion H; subst.
+ apply H2; auto.
+ unfold In; simpl.
+ left; auto.
+ apply IHa.
+ clear IHa.
+ rewrite <- app_comm_cons in H.
+ inversion H; subst.
+ inversion H3; subst.
+ apply distinct_cons; auto.
+ intros.
+ apply H2.
simpl.
- unfold stripOutVars in *.
- rewrite <- IHtree2_1.
- rewrite <- IHtree2_2.
- reflexivity.
+ right; auto.
Qed.
-Lemma update_ξ_lemma `{EQD_VV:EqDecidable VV} : forall Γ ξ (lev:HaskLevel Γ)(varstypes:Tree ??(VV*_)),
- distinct (map (@fst _ _) (leaves varstypes)) ->
- mapOptionTree (update_ξ ξ lev (leaves varstypes)) (mapOptionTree (@fst _ _) varstypes) =
- mapOptionTree (fun t => t@@ lev) (mapOptionTree (@snd _ _) varstypes).
- admit.
+Lemma distinct_swap' : forall {T}a (b:list T), distinct (app b (a::nil)) -> distinct (a::b).
+ intros.
+ apply distinct_cons.
+ induction b; intros; simpl; auto.
+ rewrite <- app_comm_cons in H.
+ inversion H; subst.
+ set (IHb H4) as H4'.
+ apply H4'.
+ inversion H0; subst; auto.
+ apply distinct_bogus in H; inversion H.
+ induction b; intros; simpl; auto.
+ apply distinct_nil.
+ apply distinct_app in H.
+ destruct H; auto.
Qed.
+Lemma in_both : forall {T}(a b:list T) x, In x (app a b) -> In x a \/ In x b.
+ induction a; intros; simpl; auto.
+ rewrite <- app_comm_cons in H.
+ inversion H.
+ subst.
+ left; left; auto.
+ set (IHa _ _ H0) as H'.
+ destruct H'.
+ left; right; auto.
+ right; auto.
+ Qed.
+Lemma distinct_lemma : forall {T} (a b:list T) a0, distinct (app a (a0 :: b)) -> distinct (app a b).
+ intros.
+ induction a; simpl; auto.
+ simpl in H.
+ inversion H; auto.
+ assert (distinct (app a1 b)) as Q.
+ intros.
+ apply IHa.
+ clear IHa.
+ rewrite <- app_comm_cons in H.
+ inversion H; subst; auto.
+ apply distinct_cons; [ idtac | apply Q ].
+ intros.
+ apply in_both in H0.
+ destruct H0.
+ rewrite <- app_comm_cons in H.
+ inversion H; subst; auto.
+ apply H3.
+ apply In_both; auto.
+ rewrite <- app_comm_cons in H.
+ inversion H; subst; auto.
+ apply H3.
+ apply In_both'; auto.
+ simpl.
+ right; auto.
+ Qed.
+Lemma nil_app : forall {T}(a:list T) x, x::a = (app (x::nil) a).
+ induction a; intros; simpl; auto.
+ Qed.
+Lemma distinct_swap : forall {T}(a b:list T), distinct (app a b) -> distinct (app b a).
+ intros.
+ induction b.
+ rewrite <- app_nil_end in H; auto.
+ rewrite <- app_comm_cons.
+ set (distinct_lemma _ _ _ H) as H'.
+ set (IHb H') as H''.
+ apply distinct_cons; [ idtac | apply H'' ].
+ intros.
+ apply in_both in H0.
+ clear H'' H'.
+ destruct H0.
+ apply distinct_app in H.
+ destruct H.
+ inversion H1; auto.
+ clear IHb.
+ rewrite nil_app in H.
+ rewrite ass_app in H.
+ apply distinct_app in H.
+ destruct H; auto.
+ apply distinct_swap' in H.
+ inversion H; auto.
+ Qed.
-Fixpoint expr2antecedent {Γ'}{Δ'}{ξ'}{τ'}(exp:Expr Γ' Δ' ξ' τ') : Tree ??VV :=
- match exp as E in Expr Γ Δ ξ τ with
- | EGlobal Γ Δ ξ _ _ => []
+Lemma update_xiv_lemma' `{EQD_VV:EqDecidable VV} Γ ξ (lev:HaskLevel Γ)(varstypes:Tree ??(VV*_)) :
+ forall v1 v2,
+ distinct (map (@fst _ _) (leaves (v1,,(varstypes,,v2)))) ->
+ mapOptionTree (update_xi ξ lev (leaves (v1,,(varstypes,,v2)))) (mapOptionTree (@fst _ _) varstypes) =
+ mapOptionTree (fun t => t@@ lev) (mapOptionTree (@snd _ _) varstypes).
+ induction varstypes; intros.
+ destruct a; simpl; [ idtac | reflexivity ].
+ destruct p.
+ simpl.
+ simpl in H.
+ induction (leaves v1).
+ simpl; auto.
+ destruct (eqd_dec v v); auto.
+ assert False. apply n. auto. inversion H0.
+ simpl.
+ destruct a.
+ destruct (eqd_dec v0 v); subst; auto.
+ simpl in H.
+ rewrite map_app in H.
+ simpl in H.
+ rewrite nil_app in H.
+ apply distinct_swap in H.
+ rewrite app_ass in H.
+ apply distinct_app in H.
+ destruct H.
+ apply distinct_swap in H0.
+ simpl in H0.
+ inversion H0; subst.
+ assert False.
+ apply H3.
+ simpl; left; auto.
+ inversion H1.
+ apply IHl.
+ simpl in H.
+ inversion H; auto.
+ set (IHvarstypes1 v1 (varstypes2,,v2)) as i1.
+ set (IHvarstypes2 (v1,,varstypes1) v2) as i2.
+ simpl in *.
+ rewrite <- i1.
+ rewrite <- i2.
+ rewrite ass_app.
+ rewrite ass_app.
+ rewrite ass_app.
+ rewrite ass_app.
+ reflexivity.
+ clear i1 i2 IHvarstypes1 IHvarstypes2.
+ repeat rewrite ass_app in *; auto.
+ clear i1 i2 IHvarstypes1 IHvarstypes2.
+ repeat rewrite ass_app in *; auto.
+ Qed.
+
+Lemma update_xiv_lemma `{EQD_VV:EqDecidable VV} Γ ξ (lev:HaskLevel Γ)(varstypes:Tree ??(VV*_)) :
+ distinct (map (@fst _ _) (leaves varstypes)) ->
+ mapOptionTree (update_xi ξ lev (leaves varstypes)) (mapOptionTree (@fst _ _) varstypes) =
+ mapOptionTree (fun t => t@@ lev) (mapOptionTree (@snd _ _) varstypes).
+ set (update_xiv_lemma' Γ ξ lev varstypes [] []) as q.
+ simpl in q.
+ rewrite <- app_nil_end in q.
+ apply q.
+ Qed.
+
+Fixpoint expr2antecedent {Γ'}{Δ'}{ξ'}{τ'}{l'}(exp:Expr Γ' Δ' ξ' τ' l') : Tree ??VV :=
+ match exp as E in Expr Γ Δ ξ τ l with
+ | EGlobal Γ Δ ξ _ _ _ => []
| EVar Γ Δ ξ ev => [ev]
| ELit Γ Δ ξ lit lev => []
| EApp Γ Δ ξ t1 t2 lev e1 e2 => (expr2antecedent e1),,(expr2antecedent e2)
| ELam Γ Δ ξ t1 t2 lev v e => stripOutVars (v::nil) (expr2antecedent e)
- | ELet Γ Δ ξ tv t lev v ev ebody => ((stripOutVars (v::nil) (expr2antecedent ebody)),,(expr2antecedent ev))
+ | ELet Γ Δ ξ tv t lev v ev ebody => (expr2antecedent ev),,((stripOutVars (v::nil) (expr2antecedent ebody)))
| EEsc Γ Δ ξ ec t lev e => expr2antecedent e
| EBrak Γ Δ ξ ec t lev e => expr2antecedent e
| ECast Γ Δ ξ γ t1 t2 lev e => expr2antecedent e
- | ENote Γ Δ ξ t n e => expr2antecedent e
- | ETyLam Γ Δ ξ κ σ l e => expr2antecedent e
+ | ENote Γ Δ ξ t l n e => expr2antecedent e
+ | ETyLam Γ Δ ξ κ σ l n e => expr2antecedent e
| ECoLam Γ Δ κ σ σ₁ σ₂ ξ l e => expr2antecedent e
| ECoApp Γ Δ κ γ σ₁ σ₂ σ ξ l e => expr2antecedent e
| ETyApp Γ Δ κ σ τ ξ l e => expr2antecedent e
- | ELetRec Γ Δ ξ l τ vars branches body =>
+ | ELetRec Γ Δ ξ l τ vars _ branches body =>
let branch_context := eLetRecContext branches
- in let all_contexts := (expr2antecedent body),,branch_context
+ in let all_contexts := branch_context,,(expr2antecedent body)
in stripOutVars (leaves (mapOptionTree (@fst _ _ ) vars)) all_contexts
| ECase Γ Δ ξ l tc tbranches atypes e' alts =>
((fix varsfromalts (alts:
Tree ??{ sac : _ & { scb : StrongCaseBranchWithVVs _ _ tc atypes sac
- & Expr (sac_Γ sac Γ)
- (sac_Δ sac Γ atypes (weakCK'' Δ))
- (scbwv_ξ scb ξ l)
- (weakLT' (tbranches@@l)) } }
+ & Expr (sac_gamma sac Γ)
+ (sac_delta sac Γ atypes (weakCK'' Δ))
+ (scbwv_xi scb ξ l)
+ (weakT' tbranches) (weakL' l)} }
): Tree ??VV :=
match alts with
| T_Leaf None => []
| ELR_branch Γ Δ ξ lev t1 t2 b1 b2 => (eLetRecContext b1),,(eLetRecContext b2)
end.
-Definition mkProofCaseBranch {Γ}{Δ}{ξ}{l}{tc}{tbranches}{atypes}
-(alt : { sac : _ & { scb : StrongCaseBranchWithVVs _ _ tc atypes sac
- & Expr (sac_Γ sac Γ)
- (sac_Δ sac Γ atypes (weakCK'' Δ))
- (scbwv_ξ scb ξ l)
- (weakLT' (tbranches@@l)) } })
- : { sac : _ & ProofCaseBranch tc Γ Δ l tbranches atypes sac }.
- destruct alt.
- exists x.
- exact
- {| pcb_freevars := mapOptionTree ξ
- (stripOutVars (vec2list (scbwv_exprvars (projT1 s)))
- (expr2antecedent (projT2 s)))
- |}.
- Defined.
-
-
Fixpoint eLetRecTypes {Γ}{Δ}{ξ}{lev}{τ}(elrb:ELetRecBindings Γ Δ ξ lev τ) : Tree ??(HaskType Γ ★) :=
match elrb with
| ELR_nil Γ Δ ξ lev => []
reflexivity.
Qed.
-Definition arrangeContext
+Definition factorContextLeft
+ (Γ:TypeEnv)(Δ:CoercionEnv Γ)
+ v (* variable to be pivoted, if found *)
+ ctx (* initial context *)
+ (ξ:VV -> LeveledHaskType Γ ★)
+ :
+
+ (* a proof concluding in a context where that variable does not appear *)
+ sum (Arrange
+ (mapOptionTree ξ ctx )
+ (mapOptionTree ξ ([],,(stripOutVars (v::nil) ctx)) ))
+
+ (* or a proof concluding in a context where that variable appears exactly once in the left branch *)
+ (Arrange
+ (mapOptionTree ξ ctx )
+ (mapOptionTree ξ ([v],,(stripOutVars (v::nil) ctx)) )).
+
+ induction ctx.
+
+ refine (match a with None => let case_None := tt in _ | Some v' => let case_Some := tt in _ end).
+
+ (* nonempty leaf *)
+ destruct case_Some.
+ unfold stripOutVars in *; simpl.
+ unfold dropVar.
+ unfold mapOptionTree in *; simpl; fold (mapOptionTree ξ) in *.
+
+ destruct (eqd_dec v' v); subst.
+
+ (* where the leaf is v *)
+ apply inr.
+ subst.
+ apply AuCanR.
+
+ (* where the leaf is NOT v *)
+ apply inl.
+ apply AuCanL.
+
+ (* empty leaf *)
+ destruct case_None.
+ apply inl; simpl in *.
+ apply AuCanR.
+
+ (* branch *)
+ refine (
+ match IHctx1 with
+ | inr lpf =>
+ match IHctx2 with
+ | inr rpf => let case_Both := tt in _
+ | inl rpf => let case_Left := tt in _
+ end
+ | inl lpf =>
+ match IHctx2 with
+ | inr rpf => let case_Right := tt in _
+ | inl rpf => let case_Neither := tt in _
+ end
+ end); clear IHctx1; clear IHctx2.
+
+ destruct case_Neither.
+ apply inl.
+ simpl.
+ eapply AComp; [idtac | apply AuCanL ].
+ exact (AComp
+ (* order will not matter because these are central as morphisms *)
+ (ARight _ (AComp lpf (ACanL _)))
+ (ALeft _ (AComp rpf (ACanL _)))).
+
+ destruct case_Right.
+ apply inr.
+ unfold mapOptionTree in *; simpl; fold (mapOptionTree ξ) in *.
+ fold (stripOutVars (v::nil)).
+ eapply AComp; [ idtac | eapply pivotContext' ].
+ eapply AComp.
+ eapply ARight.
+ eapply AComp.
+ apply lpf.
+ apply ACanL.
+ eapply ALeft.
+ apply rpf.
+
+ destruct case_Left.
+ apply inr.
+ fold (stripOutVars (v::nil)).
+ simpl.
+ eapply AComp.
+ eapply ALeft.
+ eapply AComp.
+ apply rpf.
+ simpl.
+ eapply ACanL.
+ eapply AComp; [ idtac | eapply AuAssoc ].
+ eapply ARight.
+ apply lpf.
+
+ destruct case_Both.
+ apply inr.
+ simpl.
+ eapply AComp; [ idtac | eapply ARight; eapply ACont ].
+ eapply AComp; [ eapply ARight; eapply lpf | idtac ].
+ eapply AComp; [ eapply ALeft; eapply rpf | idtac ].
+ clear lpf rpf.
+ simpl.
+ apply arrangeSwapMiddle.
+ Defined.
+
+Definition factorContextRight
(Γ:TypeEnv)(Δ:CoercionEnv Γ)
v (* variable to be pivoted, if found *)
ctx (* initial context *)
(* where the leaf is v *)
apply inr.
subst.
- apply RuCanL.
+ apply AuCanL.
(* where the leaf is NOT v *)
apply inl.
- apply RuCanR.
+ apply AuCanR.
(* empty leaf *)
destruct case_None.
apply inl; simpl in *.
- apply RuCanR.
+ apply AuCanR.
(* branch *)
refine (
destruct case_Neither.
apply inl.
- eapply RComp; [idtac | apply RuCanR ].
- exact (RComp
+ eapply AComp; [idtac | apply AuCanR ].
+ exact (AComp
(* order will not matter because these are central as morphisms *)
- (RRight _ (RComp lpf (RCanR _)))
- (RLeft _ (RComp rpf (RCanR _)))).
+ (ARight _ (AComp lpf (ACanR _)))
+ (ALeft _ (AComp rpf (ACanR _)))).
destruct case_Right.
apply inr.
fold (stripOutVars (v::nil)).
- set (RRight (mapOptionTree ξ ctx2) (RComp lpf ((RCanR _)))) as q.
+ set (ARight (mapOptionTree ξ ctx2) (AComp lpf ((ACanR _)))) as q.
simpl in *.
- eapply RComp.
+ eapply AComp.
apply q.
clear q.
clear lpf.
unfold mapOptionTree in *; simpl; fold (mapOptionTree ξ) in *.
- eapply RComp; [ idtac | apply RAssoc ].
- apply RLeft.
+ eapply AComp; [ idtac | apply AAssoc ].
+ apply ALeft.
apply rpf.
destruct case_Left.
apply inr.
unfold mapOptionTree in *; simpl; fold (mapOptionTree ξ) in *.
fold (stripOutVars (v::nil)).
- eapply RComp; [ idtac | eapply pivotContext ].
- set (RComp rpf (RCanR _ )) as rpf'.
- set (RLeft ((mapOptionTree ξ (stripOutVars (v :: nil) ctx1),, [ξ v])) rpf') as qq.
+ eapply AComp; [ idtac | eapply pivotContext ].
+ set (AComp rpf (ACanR _ )) as rpf'.
+ set (ALeft ((mapOptionTree ξ (stripOutVars (v :: nil) ctx1),, [ξ v])) rpf') as qq.
simpl in *.
- eapply RComp; [ idtac | apply qq ].
+ eapply AComp; [ idtac | apply qq ].
clear qq rpf' rpf.
- apply (RRight (mapOptionTree ξ ctx2)).
+ apply (ARight (mapOptionTree ξ ctx2)).
apply lpf.
destruct case_Both.
apply inr.
unfold mapOptionTree in *; simpl; fold (mapOptionTree ξ) in *.
fold (stripOutVars (v::nil)).
- eapply RComp; [ idtac | eapply copyAndPivotContext ].
+ eapply AComp; [ idtac | eapply copyAndPivotContext ].
(* order will not matter because these are central as morphisms *)
- exact (RComp (RRight _ lpf) (RLeft _ rpf)).
+ exact (AComp (ARight _ lpf) (ALeft _ rpf)).
Defined.
-(* same as before, but use RWeak if necessary *)
-Definition arrangeContextAndWeaken
+(* same as before, but use AWeak if necessary *)
+Definition factorContextLeftAndWeaken
(Γ:TypeEnv)(Δ:CoercionEnv Γ)
v (* variable to be pivoted, if found *)
ctx (* initial context *)
(ξ:VV -> LeveledHaskType Γ ★) :
Arrange
(mapOptionTree ξ ctx )
- (mapOptionTree ξ ((stripOutVars (v::nil) ctx),,[v]) ).
- set (arrangeContext Γ Δ v ctx ξ) as q.
+ (mapOptionTree ξ ([v],,(stripOutVars (v::nil) ctx)) ).
+ set (factorContextLeft Γ Δ v ctx ξ) as q.
destruct q; auto.
- eapply RComp; [ apply a | idtac ].
- refine (RLeft _ (RWeak _)).
+ eapply AComp; [ apply a | idtac ].
+ refine (ARight _ (AWeak _)).
Defined.
-Lemma cheat : forall {T}(a b:list T), distinct (app a b) -> distinct (app b a).
- admit.
- Qed.
+Definition factorContextLeftAndWeaken''
+ (Γ:TypeEnv)(Δ:CoercionEnv Γ)
+ v (* variable to be pivoted, if found *)
+ (ξ:VV -> LeveledHaskType Γ ★) : forall ctx,
+ distinct (leaves v) ->
+ Arrange
+ ((mapOptionTree ξ ctx) )
+ ((mapOptionTree ξ v),,(mapOptionTree ξ (stripOutVars (leaves v) ctx))).
-Definition arrangeContextAndWeaken''
+ induction v; intros.
+ destruct a.
+ unfold mapOptionTree in *.
+ simpl in *.
+ fold (mapOptionTree ξ) in *.
+ intros.
+ set (@factorContextLeftAndWeaken) as q.
+ simpl in q.
+ apply q.
+ apply Δ.
+
+ unfold mapOptionTree; simpl in *.
+ intros.
+ rewrite (@stripping_nothing_is_inert Γ); auto.
+ apply AuCanL.
+ intros.
+ unfold mapOptionTree in *.
+ simpl in *.
+ fold (mapOptionTree ξ) in *.
+ set (mapOptionTree ξ) as X in *.
+
+ set (distinct_app _ _ _ H) as H'.
+ destruct H' as [H1 H2].
+
+ set (IHv1 (v2,,(stripOutVars (leaves v2) ctx))) as IHv1'.
+
+ unfold X in *.
+ simpl in *.
+ rewrite <- strip_twice_lemma.
+ set (notin_strip_inert' v2 (leaves v1)) as q.
+ unfold stripOutVars in q.
+ rewrite q in IHv1'.
+ clear q.
+ eapply AComp; [ idtac | eapply AAssoc ].
+ eapply AComp; [ idtac | eapply IHv1' ].
+ clear IHv1'.
+ apply IHv2; auto.
+ auto.
+ auto.
+ Defined.
+
+(* same as before, but use AWeak if necessary *)
+Definition factorContextRightAndWeaken
+ (Γ:TypeEnv)(Δ:CoercionEnv Γ)
+ v (* variable to be pivoted, if found *)
+ ctx (* initial context *)
+ (ξ:VV -> LeveledHaskType Γ ★) :
+ Arrange
+ (mapOptionTree ξ ctx )
+ (mapOptionTree ξ ((stripOutVars (v::nil) ctx),,[v]) ).
+ set (factorContextRight Γ Δ v ctx ξ) as q.
+ destruct q; auto.
+ eapply AComp; [ apply a | idtac ].
+ refine (ALeft _ (AWeak _)).
+ Defined.
+
+Definition factorContextRightAndWeaken''
(Γ:TypeEnv)(Δ:CoercionEnv Γ)
v (* variable to be pivoted, if found *)
(ξ:VV -> LeveledHaskType Γ ★) : forall ctx,
simpl in *.
fold (mapOptionTree ξ) in *.
intros.
- apply arrangeContextAndWeaken.
+ apply factorContextRightAndWeaken.
apply Δ.
unfold mapOptionTree; simpl in *.
intros.
rewrite (@stripping_nothing_is_inert Γ); auto.
- apply RuCanR.
+ apply AuCanR.
intros.
unfold mapOptionTree in *.
simpl in *.
fold X in IHv2'.
set (distinct_app _ _ _ H) as H'.
destruct H' as [H1 H2].
- set (RComp (IHv1 _ H1) (IHv2' H2)) as qq.
- eapply RComp.
+ set (AComp (IHv1 _ H1) (IHv2' H2)) as qq.
+ eapply AComp.
apply qq.
clear qq IHv2' IHv2 IHv1.
+ rewrite strip_swap_lemma.
rewrite strip_twice_lemma.
-
- rewrite (strip_distinct' v1 (leaves v2)).
- apply RCossa.
- apply cheat.
+ rewrite (notin_strip_inert' v1 (leaves v2)).
+ apply AuAssoc.
+ apply distinct_swap.
auto.
Defined.
Lemma updating_stripped_tree_is_inert {Γ} (ξ:VV -> LeveledHaskType Γ ★) v tree t lev :
- mapOptionTree (update_ξ ξ lev ((v,t)::nil)) (stripOutVars (v :: nil) tree)
+ mapOptionTree (update_xi ξ lev ((v,t)::nil)) (stripOutVars (v :: nil) tree)
= mapOptionTree ξ (stripOutVars (v :: nil) tree).
set (@updating_stripped_tree_is_inert' Γ lev ξ ((v,t)::nil)) as p.
rewrite p.
Inductive LetRecSubproofs Γ Δ ξ lev : forall tree, ELetRecBindings Γ Δ ξ lev tree -> Type :=
| lrsp_nil : LetRecSubproofs Γ Δ ξ lev [] (ELR_nil _ _ _ _)
| lrsp_leaf : forall v t e ,
- (ND Rule [] [Γ > Δ > mapOptionTree ξ (expr2antecedent e) |- [t@@lev]]) ->
+ (ND Rule [] [Γ > Δ > mapOptionTree ξ (expr2antecedent e) |- [t]@lev]) ->
LetRecSubproofs Γ Δ ξ lev [(v, t)] (ELR_leaf _ _ _ _ _ t e)
| lrsp_cons : forall t1 t2 b1 b2,
LetRecSubproofs Γ Δ ξ lev t1 b1 ->
Lemma letRecSubproofsToND Γ Δ ξ lev tree branches :
LetRecSubproofs Γ Δ ξ lev tree branches ->
ND Rule [] [ Γ > Δ > mapOptionTree ξ (eLetRecContext branches)
- |- (mapOptionTree (@snd _ _) tree) @@@ lev ].
+ |- (mapOptionTree (@snd _ _) tree) @ lev ].
intro X; induction X; intros; simpl in *.
apply nd_rule.
apply RVoid.
destruct q.
simpl in *.
apply n.
- eapply nd_comp; [ idtac | eapply nd_rule; apply RJoin ].
- eapply nd_comp; [ apply nd_llecnac | idtac ].
- apply nd_prod; auto.
- Defined.
+ eapply nd_comp; [ idtac | eapply RCut' ].
+ eapply nd_comp; [ apply nd_llecnac | idtac ].
+ apply nd_prod.
+ apply IHX1.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RLeft ].
+ apply IHX2.
+ Defined.
Lemma letRecSubproofsToND' Γ Δ ξ lev τ tree :
- forall branches body,
- distinct (leaves (mapOptionTree (@fst _ _) tree)) ->
- ND Rule [] [Γ > Δ > mapOptionTree (update_ξ ξ lev (leaves tree)) (expr2antecedent body) |- [τ @@ lev]] ->
- LetRecSubproofs Γ Δ (update_ξ ξ lev (leaves tree)) lev tree branches ->
- ND Rule [] [Γ > Δ > mapOptionTree ξ (expr2antecedent (@ELetRec VV _ Γ Δ ξ lev τ tree branches body)) |- [τ @@ lev]].
+ forall branches body (dist:distinct (leaves (mapOptionTree (@fst _ _) tree))),
+ ND Rule [] [Γ > Δ > mapOptionTree (update_xi ξ lev (leaves tree)) (expr2antecedent body) |- [τ ]@ lev] ->
+ LetRecSubproofs Γ Δ (update_xi ξ lev (leaves tree)) lev tree branches ->
+ ND Rule [] [Γ > Δ > mapOptionTree ξ (expr2antecedent (@ELetRec VV _ Γ Δ ξ lev τ tree dist branches body)) |- [τ ]@ lev].
(* NOTE: how we interpret stuff here affects the order-of-side-effects *)
intro branches.
intro pf.
intro lrsp.
- rewrite mapleaves in disti.
- set (@update_ξ_lemma _ Γ ξ lev tree disti) as ξlemma.
+ assert (distinct (leaves (mapOptionTree (@fst _ _) tree))) as disti'.
+ apply disti.
+ rewrite mapleaves in disti'.
+
+ set (@update_xiv_lemma _ Γ ξ lev tree disti') as ξlemma.
rewrite <- mapOptionTree_compose in ξlemma.
- set ((update_ξ ξ lev (leaves tree))) as ξ' in *.
+ set ((update_xi ξ lev (leaves tree))) as ξ' in *.
set ((stripOutVars (leaves (mapOptionTree (@fst _ _) tree)) (eLetRecContext branches))) as ctx.
set (mapOptionTree (@fst _ _) tree) as pctx.
set (mapOptionTree ξ' pctx) as passback.
eapply nd_comp; [ idtac | eapply nd_rule; apply z ].
clear z.
- set (@arrangeContextAndWeaken'' Γ Δ pctx ξ' (expr2antecedent body,,eLetRecContext branches)) as q'.
+ set (@factorContextLeftAndWeaken'' Γ Δ pctx ξ' (eLetRecContext branches,,expr2antecedent body)) as q'.
unfold passback in *; clear passback.
unfold pctx in *; clear pctx.
- rewrite <- mapleaves in disti.
set (q' disti) as q''.
unfold ξ' in *.
simpl.
rewrite <- mapOptionTree_compose in q''.
rewrite <- ξlemma.
- eapply nd_comp; [ idtac | eapply nd_rule; apply (RArrange _ _ _ _ _ q'') ].
+ eapply nd_comp; [ idtac | eapply nd_rule; apply (RArrange _ _ _ _ _ _ q'') ].
clear q'.
clear q''.
simpl.
set (letRecSubproofsToND _ _ _ _ _ branches lrsp) as q.
- eapply nd_comp; [ idtac | eapply nd_rule; apply RJoin ].
- eapply nd_comp; [ apply nd_llecnac | idtac ].
- apply nd_prod; auto.
- rewrite ξlemma.
- apply q.
- Defined.
+
+ eapply nd_comp; [ idtac | eapply RCut' ].
+ eapply nd_comp; [ apply nd_llecnac | idtac ].
+ apply nd_prod.
+ apply q.
+ eapply nd_comp; [ idtac | eapply nd_rule; eapply RLeft ].
+ apply pf.
+ Defined.
Lemma scbwv_coherent {tc}{Γ}{atypes:IList _ (HaskType Γ) _}{sac} :
forall scb:StrongCaseBranchWithVVs _ _ tc atypes sac,
forall l ξ,
- vec2list (vec_map (scbwv_ξ scb ξ l) (scbwv_exprvars scb)) =
+ vec2list (vec_map (scbwv_xi scb ξ l) (scbwv_exprvars scb)) =
vec2list (vec_map (fun t => t @@ weakL' l) (sac_types sac _ atypes)).
intros.
- unfold scbwv_ξ.
+ unfold scbwv_xi.
unfold scbwv_varstypes.
- set (@update_ξ_lemma _ _ (weakLT' ○ ξ) (weakL' l)
+ set (@update_xiv_lemma _ _ (weakLT' ○ ξ) (weakL' l)
(unleaves (vec2list (vec_zip (scbwv_exprvars scb) (sac_types sac Γ atypes))))
) as q.
rewrite <- mapleaves' in q.
Qed.
+Definition mkProofCaseBranch {Γ}{Δ}{ξ}{l}{tc}{tbranches}{atypes}
+(alt : { sac : _ & { scb : StrongCaseBranchWithVVs _ _ tc atypes sac
+ & Expr (sac_gamma sac Γ)
+ (sac_delta sac Γ atypes (weakCK'' Δ))
+ (scbwv_xi scb ξ l)
+ (weakT' tbranches) (weakL' l) } })
+ : @StrongAltCon tc * Tree ??(LeveledHaskType Γ ★).
+ destruct alt.
+ split.
+ apply x.
+ apply (mapOptionTree ξ
+ (stripOutVars (vec2list (scbwv_exprvars (projT1 s)))
+ (expr2antecedent (projT2 s)))).
+ Defined.
+
Lemma case_lemma : forall Γ Δ ξ l tc tbranches atypes e
(alts':Tree
??{sac : StrongAltCon &
{scb : StrongCaseBranchWithVVs VV eqd_vv tc atypes sac &
- Expr (sac_Γ sac Γ) (sac_Δ sac Γ atypes (weakCK'' Δ))
- (scbwv_ξ scb ξ l) (weakLT' (tbranches @@ l))}}),
+ Expr (sac_gamma sac Γ) (sac_delta sac Γ atypes (weakCK'' Δ))
+ (scbwv_xi scb ξ l) (weakT' tbranches) (weakL' l)}}),
- (mapOptionTreeAndFlatten (fun x => pcb_freevars (projT2 x))
+ (mapOptionTreeAndFlatten (fun x => snd x)
(mapOptionTree mkProofCaseBranch alts'))
,,
mapOptionTree ξ (expr2antecedent e) =
Qed.
Definition expr2proof :
- forall Γ Δ ξ τ (e:Expr Γ Δ ξ τ),
- ND Rule [] [Γ > Δ > mapOptionTree ξ (expr2antecedent e) |- [τ]].
+ forall Γ Δ ξ τ l (e:Expr Γ Δ ξ τ l),
+ ND Rule [] [Γ > Δ > mapOptionTree ξ (expr2antecedent e) |- [τ] @ l].
- refine (fix expr2proof Γ' Δ' ξ' τ' (exp:Expr Γ' Δ' ξ' τ') {struct exp}
- : ND Rule [] [Γ' > Δ' > mapOptionTree ξ' (expr2antecedent exp) |- [τ']] :=
- match exp as E in Expr Γ Δ ξ τ with
- | EGlobal Γ Δ ξ t wev => let case_EGlobal := tt in _
+ refine (fix expr2proof Γ' Δ' ξ' τ' l' (exp:Expr Γ' Δ' ξ' τ' l') {struct exp}
+ : ND Rule [] [Γ' > Δ' > mapOptionTree ξ' (expr2antecedent exp) |- [τ'] @ l'] :=
+ match exp as E in Expr Γ Δ ξ τ l with
+ | EGlobal Γ Δ ξ g v lev => let case_EGlobal := tt in _
| EVar Γ Δ ξ ev => let case_EVar := tt in _
| ELit Γ Δ ξ lit lev => let case_ELit := tt in _
| EApp Γ Δ ξ t1 t2 lev e1 e2 => let case_EApp := tt in
- (fun e1' e2' => _) (expr2proof _ _ _ _ e1) (expr2proof _ _ _ _ e2)
- | ELam Γ Δ ξ t1 t2 lev v e => let case_ELam := tt in (fun e' => _) (expr2proof _ _ _ _ e)
+ (fun e1' e2' => _) (expr2proof _ _ _ _ _ e1) (expr2proof _ _ _ _ _ e2)
+ | ELam Γ Δ ξ t1 t2 lev v e => let case_ELam := tt in (fun e' => _) (expr2proof _ _ _ _ _ e)
| ELet Γ Δ ξ tv t v lev ev ebody => let case_ELet := tt in
- (fun pf_let pf_body => _) (expr2proof _ _ _ _ ev) (expr2proof _ _ _ _ ebody)
- | ELetRec Γ Δ ξ lev t tree branches ebody =>
- let ξ' := update_ξ ξ lev (leaves tree) in
- let case_ELetRec := tt in (fun e' subproofs => _) (expr2proof _ _ _ _ ebody)
+ (fun pf_let pf_body => _) (expr2proof _ _ _ _ _ ev) (expr2proof _ _ _ _ _ ebody)
+ | ELetRec Γ Δ ξ lev t tree disti branches ebody =>
+ let ξ' := update_xi ξ lev (leaves tree) in
+ let case_ELetRec := tt in (fun e' subproofs => _) (expr2proof _ _ _ _ _ ebody)
((fix subproofs Γ'' Δ'' ξ'' lev'' (tree':Tree ??(VV * HaskType Γ'' ★))
(branches':ELetRecBindings Γ'' Δ'' ξ'' lev'' tree')
: LetRecSubproofs Γ'' Δ'' ξ'' lev'' tree' branches' :=
match branches' as B in ELetRecBindings G D X L T return LetRecSubproofs G D X L T B with
| ELR_nil Γ Δ ξ lev => lrsp_nil _ _ _ _
- | ELR_leaf Γ Δ ξ l v t e => lrsp_leaf Γ Δ ξ l v t e (expr2proof _ _ _ _ e)
+ | ELR_leaf Γ Δ ξ l v t e => lrsp_leaf Γ Δ ξ l v t e (expr2proof _ _ _ _ _ e)
| ELR_branch Γ Δ ξ lev t1 t2 b1 b2 => lrsp_cons _ _ _ _ _ _ _ _ (subproofs _ _ _ _ _ b1) (subproofs _ _ _ _ _ b2)
end
) _ _ _ _ tree branches)
- | EEsc Γ Δ ξ ec t lev e => let case_EEsc := tt in (fun e' => _) (expr2proof _ _ _ _ e)
- | EBrak Γ Δ ξ ec t lev e => let case_EBrak := tt in (fun e' => _) (expr2proof _ _ _ _ e)
- | ECast Γ Δ ξ γ t1 t2 lev e => let case_ECast := tt in (fun e' => _) (expr2proof _ _ _ _ e)
- | ENote Γ Δ ξ t n e => let case_ENote := tt in (fun e' => _) (expr2proof _ _ _ _ e)
- | ETyLam Γ Δ ξ κ σ l e => let case_ETyLam := tt in (fun e' => _) (expr2proof _ _ _ _ e)
- | ECoLam Γ Δ κ σ σ₁ σ₂ ξ l e => let case_ECoLam := tt in (fun e' => _) (expr2proof _ _ _ _ e)
- | ECoApp Γ Δ κ σ₁ σ₂ σ γ ξ l e => let case_ECoApp := tt in (fun e' => _) (expr2proof _ _ _ _ e)
- | ETyApp Γ Δ κ σ τ ξ l e => let case_ETyApp := tt in (fun e' => _) (expr2proof _ _ _ _ e)
+ | EEsc Γ Δ ξ ec t lev e => let case_EEsc := tt in (fun e' => _) (expr2proof _ _ _ _ _ e)
+ | EBrak Γ Δ ξ ec t lev e => let case_EBrak := tt in (fun e' => _) (expr2proof _ _ _ _ _ e)
+ | ECast Γ Δ ξ γ t1 t2 lev e => let case_ECast := tt in (fun e' => _) (expr2proof _ _ _ _ _ e)
+ | ENote Γ Δ ξ t _ n e => let case_ENote := tt in (fun e' => _) (expr2proof _ _ _ _ _ e)
+ | ETyLam Γ Δ ξ κ σ l n e => let case_ETyLam := tt in (fun e' => _) (expr2proof _ _ _ _ _ e)
+ | ECoLam Γ Δ κ σ σ₁ σ₂ ξ l e => let case_ECoLam := tt in (fun e' => _) (expr2proof _ _ _ _ _ e)
+ | ECoApp Γ Δ κ σ₁ σ₂ σ γ ξ l e => let case_ECoApp := tt in (fun e' => _) (expr2proof _ _ _ _ _ e)
+ | ETyApp Γ Δ κ σ τ ξ l e => let case_ETyApp := tt in (fun e' => _) (expr2proof _ _ _ _ _ e)
| ECase Γ Δ ξ l tc tbranches atypes e alts' =>
let dcsp :=
((fix mkdcsp (alts:
Tree ??{ sac : _ & { scb : StrongCaseBranchWithVVs _ _ tc atypes sac
- & Expr (sac_Γ sac Γ)
- (sac_Δ sac Γ atypes (weakCK'' Δ))
- (scbwv_ξ scb ξ l)
- (weakLT' (tbranches@@l)) } })
- : ND Rule [] (mapOptionTree (fun x => pcb_judg (projT2 (mkProofCaseBranch x))) alts) :=
+ & Expr (sac_gamma sac Γ)
+ (sac_delta sac Γ atypes (weakCK'' Δ))
+ (scbwv_xi scb ξ l)
+ (weakT' tbranches) (weakL' l) } })
+ : ND Rule [] (mapOptionTree (fun x => pcb_judg (snd (mkProofCaseBranch x))) alts) :=
match alts as ALTS return ND Rule []
- (mapOptionTree (fun x => pcb_judg (projT2 (mkProofCaseBranch x))) ALTS) with
+ (mapOptionTree (fun x => pcb_judg (snd (mkProofCaseBranch x))) ALTS) with
| T_Leaf None => let case_nil := tt in _
| T_Branch b1 b2 => let case_branch := tt in (fun b1' b2' => _) (mkdcsp b1) (mkdcsp b2)
| T_Leaf (Some x) =>
- match x as X return ND Rule [] [pcb_judg (projT2 (mkProofCaseBranch X))] with
+ match x as X return ND Rule [] [@pcb_judg tc Γ Δ l tbranches atypes
+ (fst (mkProofCaseBranch X))
+ (snd (mkProofCaseBranch X))] with
existT sac (existT scbx ex) =>
- (fun e' => let case_leaf := tt in _) (expr2proof _ _ _ _ ex)
+ (fun e' => let case_leaf := tt in _) (expr2proof _ _ _ _ _ ex)
end
end) alts')
- in let case_ECase := tt in (fun e' => _) (expr2proof _ _ _ _ e)
+ in let case_ECase := tt in (fun e' => _) (expr2proof _ _ _ _ _ e)
end
- ); clear exp ξ' τ' Γ' Δ' expr2proof; try clear mkdcsp.
+ ); clear exp ξ' τ' Γ' Δ' l' expr2proof; try clear mkdcsp.
destruct case_EGlobal.
apply nd_rule.
simpl.
- destruct t as [t lev].
- apply (RGlobal _ _ _ _ wev).
+ apply (RGlobal _ _ _ g).
destruct case_EVar.
apply nd_rule.
destruct case_EApp.
unfold mapOptionTree; simpl; fold (mapOptionTree ξ).
- eapply nd_comp; [ idtac | eapply nd_rule; apply RApp ].
+ eapply nd_comp; [ idtac
+ | eapply nd_rule;
+ apply (@RApp _ _ _ _ t2 t1) ].
eapply nd_comp; [ apply nd_llecnac | idtac ].
apply nd_prod; auto.
- apply e1'.
- apply e2'.
destruct case_ELam; intros.
unfold mapOptionTree; simpl; fold (mapOptionTree ξ).
eapply nd_comp; [ idtac | eapply nd_rule; apply RLam ].
- set (update_ξ ξ lev ((v,t1)::nil)) as ξ'.
- set (arrangeContextAndWeaken Γ Δ v (expr2antecedent e) ξ') as pfx.
+ set (update_xi ξ lev ((v,t1)::nil)) as ξ'.
+ set (factorContextRightAndWeaken Γ Δ v (expr2antecedent e) ξ') as pfx.
eapply RArrange in pfx.
unfold mapOptionTree in pfx; simpl in pfx.
unfold ξ' in pfx.
rewrite updating_stripped_tree_is_inert in pfx.
- unfold update_ξ in pfx.
+ unfold update_xi in pfx.
destruct (eqd_dec v v).
eapply nd_comp; [ idtac | apply (nd_rule pfx) ].
clear pfx.
inversion H.
destruct case_ELet; intros; simpl in *.
- eapply nd_comp; [ idtac | eapply nd_rule; eapply RLet ].
- eapply nd_comp; [ apply nd_llecnac | idtac ].
+ eapply nd_comp; [ idtac | eapply RLet ].
+ eapply nd_comp; [ apply nd_rlecnac | idtac ].
apply nd_prod.
- apply pf_let.
- clear pf_let.
- eapply nd_comp; [ apply pf_body | idtac ].
- clear pf_body.
+ apply pf_let.
+ eapply nd_comp; [ apply pf_body | idtac ].
fold (@mapOptionTree VV).
fold (mapOptionTree ξ).
- set (update_ξ ξ v ((lev,tv)::nil)) as ξ'.
- set (arrangeContextAndWeaken Γ Δ lev (expr2antecedent ebody) ξ') as n.
+ set (update_xi ξ v ((lev,tv)::nil)) as ξ'.
+ set (factorContextLeftAndWeaken Γ Δ lev (expr2antecedent ebody) ξ') as n.
unfold mapOptionTree in n; simpl in n; fold (mapOptionTree ξ') in n.
unfold ξ' in n.
rewrite updating_stripped_tree_is_inert in n.
- unfold update_ξ in n.
+ unfold update_xi in n.
destruct (eqd_dec lev lev).
unfold ξ'.
- unfold update_ξ.
+ unfold update_xi.
eapply RArrange in n.
apply (nd_rule n).
assert False. apply n0; auto. inversion H.
auto.
destruct case_ENote.
- destruct t.
eapply nd_comp; [ idtac | eapply nd_rule; apply RNote ].
apply e'.
auto.
destruct case_leaf.
clear o x alts alts' e.
- eapply nd_comp; [ apply e' | idtac ].
+ simpl.
+ apply (fun x => nd_comp e' x).
clear e'.
- apply nd_rule.
- apply RArrange.
+ unfold pcb_judg.
simpl.
rewrite mapleaves'.
simpl.
rewrite <- mapOptionTree_compose.
- unfold scbwv_ξ.
+ unfold scbwv_xi.
rewrite <- mapleaves'.
rewrite vec2list_map_list2vec.
- unfold sac_Γ.
- rewrite <- (scbwv_coherent scbx l ξ).
+ unfold sac_gamma.
rewrite <- vec2list_map_list2vec.
rewrite mapleaves'.
- set (@arrangeContextAndWeaken'') as q.
- unfold scbwv_ξ.
set (@updating_stripped_tree_is_inert' _ (weakL' l) (weakLT' ○ ξ) (vec2list (scbwv_varstypes scbx))) as z.
unfold scbwv_varstypes in z.
rewrite vec2list_map_list2vec in z.
rewrite fst_zip in z.
rewrite <- z.
clear z.
- replace (stripOutVars (vec2list (scbwv_exprvars scbx))) with
- (stripOutVars (leaves (unleaves (vec2list (scbwv_exprvars scbx))))).
- apply q.
- apply (sac_Δ sac Γ atypes (weakCK'' Δ)).
- rewrite leaves_unleaves.
- apply (scbwv_exprvars_distinct scbx).
+ unfold sac_gamma in *.
+ simpl in *.
+ Unset Printing Implicit.
+ idtac.
+ apply nd_rule.
+ apply RArrange.
+ set (scbwv_exprvars_distinct scbx) as q'.
+ rewrite <- leaves_unleaves in q'.
+ apply (AComp (@factorContextRightAndWeaken'' _ (weakCE' Δ) _ _ (expr2antecedent ex) q')).
+ clear q'.
+
+ set (scbwv_coherent scbx l ξ) as H.
rewrite leaves_unleaves.
- reflexivity.
+ unfold scbwv_varstypes.
+ apply ALeft.
+ rewrite <- mapleaves'.
+ rewrite <- mapleaves'.
+ rewrite mapleaves'.
+ rewrite vec2list_map_list2vec.
+ rewrite <- H.
+ clear H.
+ rewrite <- mapleaves'.
+ rewrite vec2list_map_list2vec.
+ unfold scbwv_xi.
+ unfold scbwv_varstypes.
+ apply AId.
destruct case_nil.
apply nd_id0.
unfold ξ'1 in *.
clear ξ'1.
apply letRecSubproofsToND'.
- admit.
apply e'.
apply subproofs.
Require Import Coq.Lists.List.
Require Import Coq.Init.Specif.
Require Import HaskKinds.
-Require Import HaskLiteralsAndTyCons.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
Require Import HaskWeakTypes.
Require Import HaskWeakVars.
Require Import HaskWeak.
| WTyVarTy ec => return WCodeTy ec t2'
| _ => failM "impossible"
end
- | TyFunApp tfc tls => bind tls' = rawHaskTypeListToWeakType tls
+ | TyFunApp tfc _ _ tls => bind tls' = rawHaskTypeListToWeakType tls
; return WTyFunApp tfc tls'
end
with rawHaskTypeListToWeakType {κ}(rht:RawHaskTypeList κ) : UniqM (list WeakType) :=
Definition updateITE {Γ:TypeEnv}{TV:Kind->Type}{κ}(tv:TV κ)(ite:InstantiatedTypeEnv TV Γ) : InstantiatedTypeEnv TV (κ::Γ)
:= tv::::ite.
+ Definition updateITE_ {Γ:TypeEnv}{TV:Kind->Type}{κ}{n}(tv:TV κ)(ite:InstantiatedTypeEnv TV Γ)
+ : InstantiatedTypeEnv TV (list_ins n κ Γ).
+ rewrite list_ins_app.
+ rewrite <- (list_take_drop _ Γ n) in ite.
+ apply ilist_app.
+ apply ilist_chop in ite; auto.
+ apply ICons.
+ apply tv.
+ apply ilist_chop' in ite.
+ apply ite.
+ Defined.
+
Definition coercionToWeakCoercion Γ Δ κ t1 t2 ite (γ:@HaskCoercion Γ Δ (@mkHaskCoercionKind Γ κ t1 t2))
: UniqM WeakCoercion
:= bind t1' = @typeToWeakType Γ κ t1 ite
Context {VV}{eqVV:EqDecidable VV}{toStringVV:ToString VV}.
- Definition update_χ (χ:VV->???WeakExprVar)(vv:VV)(ev':WeakExprVar) : VV->???WeakExprVar :=
+ Definition update_chi (χ:VV->???WeakExprVar)(vv:VV)(ev':WeakExprVar) : VV->???WeakExprVar :=
fun vv' =>
if eqd_dec vv vv'
then OK ev'
else χ vv'.
- Fixpoint update_χ' (χ:VV->???WeakExprVar)(varsexprs:list (VV * WeakExprVar)) : VV->???WeakExprVar :=
+ Fixpoint update_chi' (χ:VV->???WeakExprVar)(varsexprs:list (VV * WeakExprVar)) : VV->???WeakExprVar :=
match varsexprs with
| nil => χ
- | (vv,wev)::rest => update_χ (update_χ' χ rest) vv wev
+ | (vv,wev)::rest => update_chi (update_chi' χ rest) vv wev
end.
- Fixpoint exprToWeakExpr {Γ}{Δ}{ξ}{τ}(χ:VV->???WeakExprVar)(exp:@Expr _ eqVV Γ Δ ξ τ)
+ Fixpoint exprToWeakExpr {Γ}{Δ}{ξ}{τ}{l}(χ:VV->???WeakExprVar)(exp:@Expr _ eqVV Γ Δ ξ τ l)
: InstantiatedTypeEnv (fun _ => WeakTypeVar) Γ
-> UniqM WeakExpr :=
- match exp as E in @Expr _ _ G D X L return InstantiatedTypeEnv (fun _ => WeakTypeVar) G -> UniqM WeakExpr with
+ match exp as E in @Expr _ _ G D X T L return InstantiatedTypeEnv (fun _ => WeakTypeVar) G -> UniqM WeakExpr with
| EVar Γ' _ ξ' ev => fun ite => match χ ev with OK v => return WEVar v | Error s => failM s end
- | EGlobal Γ' _ ξ' t wev => fun ite => return WEVar wev
+ | EGlobal Γ' _ ξ' g v lev => fun ite => bind tv' = mapM (ilist_to_list (ilmap (fun κ x => typeToWeakType x ite) v))
+ ; return (fold_left (fun x y => WETyApp x y) tv' (WEVar g))
| ELam Γ' _ _ tv _ _ cv e => fun ite => bind tv' = typeToWeakType tv ite
; bind ev' = mkWeakExprVar tv'
- ; bind e' = exprToWeakExpr (update_χ χ cv ev') e ite
+ ; bind e' = exprToWeakExpr (update_chi χ cv ev') e ite
; return WELam ev' e'
| ELet Γ' _ _ t _ _ ev e1 e2 => fun ite => bind tv' = typeToWeakType t ite
; bind e1' = exprToWeakExpr χ e1 ite
; bind ev' = mkWeakExprVar tv'
- ; bind e2' = exprToWeakExpr (update_χ χ ev ev') e2 ite
+ ; bind e2' = exprToWeakExpr (update_chi χ ev ev') e2 ite
; return WELet ev' e1' e2'
| ELit _ _ _ lit _ => fun ite => return WELit lit
| EApp Γ' _ _ _ _ _ e1 e2 => fun ite => bind e1' = exprToWeakExpr χ e1 ite
| EBrak Γ' _ _ ec t _ e => fun ite => bind t' = typeToWeakType t ite
; bind e' = exprToWeakExpr χ e ite
; return WEBrak hetmet_brak (ec _ ite) e' t'
- | ENote _ _ _ _ n e => fun ite => bind e' = exprToWeakExpr χ e ite
+ | ENote _ _ _ _ _ n e => fun ite => bind e' = exprToWeakExpr χ e ite
; return WENote n e'
| ETyApp Γ Δ κ σ τ ξ l e => fun ite => bind t' = typeToWeakType τ ite
; bind e' = exprToWeakExpr χ e ite
| ECast Γ Δ ξ t1 t2 γ l e => fun ite => bind e' = exprToWeakExpr χ e ite
; bind c' = coercionToWeakCoercion _ _ _ _ _ ite γ
; return WECast e' c'
- | ETyLam _ _ _ k _ _ e => fun ite => bind tv = mkWeakTypeVar k
- ; bind e' = exprToWeakExpr χ e (updateITE tv ite)
+ | ETyLam _ _ _ k _ _ n e => fun ite => bind tv = mkWeakTypeVar k
+ ; bind e' = exprToWeakExpr χ e (updateITE_ tv ite)
; return WETyLam tv e'
| ECoLam Γ Δ κ σ σ₁ σ₂ ξ l e => fun ite => bind t1' = typeToWeakType σ₁ ite
; bind t2' = typeToWeakType σ₂ ite
; bind tbranches' = @typeToWeakType Γ _ tbranches ite
; bind escrut' = exprToWeakExpr χ escrut ite
; bind branches' =
- ((fix caseBranches (tree:Tree ??{sac : _ & { scb : StrongCaseBranchWithVVs VV _ _ _ sac & Expr _ _ _ _ } })
+ ((fix caseBranches (tree:Tree ??{sac : _ & { scb : StrongCaseBranchWithVVs VV _ _ _ sac & Expr _ _ _ _ _ } })
: UniqM (Tree ??(WeakAltCon*list WeakTypeVar*list WeakCoerVar*list WeakExprVar*WeakExpr)) :=
match tree with
| T_Leaf None => return []
; bind v' = mkWeakExprVar tleaf
; return ((fst vt),v'))
varstypes)
- ; let χ' := update_χ' χ exprvars in
+ ; let χ' := update_chi' χ exprvars in
bind e'' = exprToWeakExpr χ' e (snd evars_ite)
; return [(sac_altcon sac, vec2list (fst evars_ite), nil, (map (@snd _ _) exprvars), e'')]
| T_Branch b1 b2 => bind b1' = caseBranches b1
(fun _ => UniqM WeakType) _ (fun _ t => typeToWeakType t ite) atypes))
; return WECase vscrut' escrut' tbranches' tc tys branches'
- | ELetRec _ _ _ _ _ vars elrb e => fun ite => bind vars' = seqM (map (fun vt:VV * HaskType _ ★
+ | ELetRec _ _ _ _ _ vars disti elrb e => fun ite => bind vars' = seqM (map (fun vt:VV * HaskType _ ★
=> bind tleaf = typeToWeakType (snd vt) ite
; bind v' = mkWeakExprVar tleaf
; return ((fst vt),v'))
(leaves vars))
- ; let χ' := update_χ' χ vars' in
+ ; let χ' := update_chi' χ vars' in
bind elrb' = exprLetRec2WeakExprLetRec χ' elrb ite
; bind e' = exprToWeakExpr χ' e ite
; return WELetRec elrb' e'
end.
- Fixpoint strongExprToWeakExpr (us:UniqSupply){Γ}{Δ}{ξ}{τ}(exp:@Expr _ eqVV Γ Δ ξ τ)
+ Fixpoint strongExprToWeakExpr (us:UniqSupply){Γ}{Δ}{ξ}{τ}{l}(exp:@Expr _ eqVV Γ Δ ξ τ l)
(ite:InstantiatedTypeEnv (fun _ => WeakTypeVar) Γ)
: ???WeakExpr :=
match exprToWeakExpr (fun v => Error ("unbound variable " +++ toString v)) exp ite with
Require Import Coq.Lists.List.
Require Import General.
Require Import HaskKinds.
-Require Import HaskLiteralsAndTyCons.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
Require Import HaskCoreTypes.
Require Import HaskCoreVars.
Require Import HaskWeakTypes.
Variable dataConTyCon : CoreDataCon -> TyCon. Extract Inlined Constant dataConTyCon => "DataCon.dataConTyCon".
Variable dataConExVars_ : CoreDataCon -> list CoreVar. Extract Inlined Constant dataConExVars_ => "DataCon.dataConExTyVars".
-Variable dataConEqTheta_ : CoreDataCon -> list PredType. Extract Inlined Constant dataConEqTheta_ => "DataCon.dataConEqTheta".
+Variable dataConEqTheta_ : CoreDataCon -> list PredType. Extract Inlined Constant dataConEqTheta_ => "DataCon.dataConTheta".
Variable dataConOrigArgTys_: CoreDataCon -> list CoreType. Extract Inlined Constant dataConOrigArgTys_=>"DataCon.dataConOrigArgTys".
Definition dataConExTyVars cdc :=
- filter (map (fun x => match coreVarToWeakVar x with WTypeVar v => Some v | _ => None end) (dataConExVars_ cdc)).
+ filter (map (fun x => match coreVarToWeakVar' x with OK (WTypeVar v) => Some v | _ => None end) (dataConExVars_ cdc)).
Opaque dataConExTyVars.
Definition dataConCoerKinds cdc :=
filter (map (fun x => match x with EqPred t1 t2 =>
| TVar : ∀ κ, TV κ -> RawHaskType κ (* a *)
| TCon : ∀ tc, RawHaskType (tyConKind' tc) (* T *)
| TArrow : RawHaskType (★ ⇛★ ⇛★ ) (* (->) *)
+ (*
+ | TKappa : RawHaskType (★ ⇛★ ⇛★ ) (* (~~>) *)
+ *)
| TCoerc : ∀ κ, RawHaskType κ -> RawHaskType κ -> RawHaskType ★ -> RawHaskType ★ (* (+>) *)
| TApp : ∀ κ₁ κ₂, RawHaskType (κ₂⇛κ₁) -> RawHaskType κ₂ -> RawHaskType κ₁ (* φ φ *)
| TAll : ∀ κ, (TV κ -> RawHaskType ★) -> RawHaskType ★ (* ∀a:κ.φ *)
- | TCode : RawHaskType ★ -> RawHaskType ★ -> RawHaskType ★ (* from λ^α *)
- | TyFunApp : ∀ tf, RawHaskTypeList (fst (tyFunKind tf)) -> RawHaskType (snd (tyFunKind tf)) (* S_n *)
+ | TCode : RawHaskType ECKind -> RawHaskType ★ -> RawHaskType ★ (* from λ^α *)
+ | TyFunApp : forall (tf:TyFun) kl k, RawHaskTypeList kl -> RawHaskType k (* S_n *)
with RawHaskTypeList : list Kind -> Type :=
| TyFunApp_nil : RawHaskTypeList nil
| TyFunApp_cons : ∀ κ kl, RawHaskType κ -> RawHaskTypeList kl -> RawHaskTypeList (κ::kl).
Implicit Arguments TAll [ [TV] ].
Notation "t1 ---> t2" := (fun TV env => (TApp (TApp TArrow (t1 TV env)) (t2 TV env))).
+(*Notation "t1 ~~~> t2" := (fun TV env => (TApp (TApp TKappa (t1 TV env)) (t2 TV env))).*)
Notation "φ₁ ∼∼ φ₂ ⇒ φ₃" := (fun TV env => TCoerc (φ₁ TV env) (φ₂ TV env) (φ₃ TV env)).
(* Kind and Coercion Environments *)
(* A (HaskXX Γ) is an XX which is valid in environments of shape Γ; they are always PHOAS-uninstantiated *)
Definition HaskTyVar (Γ:TypeEnv) κ := forall TV (env:@InstantiatedTypeEnv TV Γ), TV κ.
Definition HaskCoVar Γ Δ := forall TV CV (env:@InstantiatedTypeEnv TV Γ)(cenv:@InstantiatedCoercionEnv TV CV Γ Δ), CV.
-Definition HaskLevel (Γ:TypeEnv) := list (HaskTyVar Γ ★).
+Definition HaskLevel (Γ:TypeEnv) := list (HaskTyVar Γ ECKind).
Definition HaskType (Γ:TypeEnv) κ := ∀ TV, @InstantiatedTypeEnv TV Γ -> RawHaskType TV κ.
Definition haskTyVarToType {Γ}{κ}(htv:HaskTyVar Γ κ) : HaskType Γ κ := fun TV ite => TVar (htv TV ite).
Inductive LeveledHaskType (Γ:TypeEnv) κ := mkLeveledHaskType : HaskType Γ κ -> HaskLevel Γ -> LeveledHaskType Γ κ.
Definition FreshHaskTyVar {Γ}(κ:Kind) : HaskTyVar (κ::Γ) κ := fun TV env => ilist_head env.
+
Definition HaskTAll {Γ}(κ:Kind)(σ:forall TV (env:@InstantiatedTypeEnv TV Γ), TV κ -> RawHaskType TV ★) : HaskType Γ ★
:= fun TV env => TAll κ (σ TV env).
Definition HaskTApp {Γ}{κ}(σ:forall TV (env:@InstantiatedTypeEnv TV Γ), TV κ -> RawHaskType TV ★)
(cv:HaskTyVar Γ κ) : HaskType Γ ★
:= fun TV env => σ TV env (cv TV env).
-Definition HaskBrak {Γ}(v:HaskTyVar Γ ★)(t:HaskType Γ ★) : HaskType Γ ★:=
+Definition HaskBrak {Γ}(v:HaskTyVar Γ ECKind)(t:HaskType Γ ★) : HaskType Γ ★:=
fun TV env => @TCode TV (TVar (v TV env)) (t TV env).
Definition HaskTCon {Γ}(tc:TyCon) : HaskType Γ (fold_right KindArrow ★ (tyConKind tc))
:= fun TV ite => TCon tc.
Definition mkHaskCoercionKind {Γ}{κ}(t1:HaskType Γ κ)(t2:HaskType Γ κ) : HaskCoercionKind Γ :=
fun TV ite => mkRawCoercionKind _ (t1 TV ite) (t2 TV ite).
-(* PHOAS substitution on types *)
-Definition substT {Γ}{κ₁}{κ₂}(exp:forall TV (env:@InstantiatedTypeEnv TV Γ), TV κ₁ -> RawHaskType TV κ₂)(v:@HaskType Γ κ₁)
- : @HaskType Γ κ₂ :=
-fun TV env =>
- (fix flattenT {κ} (exp: RawHaskType (fun k => RawHaskType TV k) κ) : RawHaskType TV κ :=
+Section Flatten.
+ Context {TV:Kind -> Type }.
+Fixpoint flattenT {κ} (exp: RawHaskType (fun k => RawHaskType TV k) κ) : RawHaskType TV κ :=
match exp with
| TVar _ x => x
- | TAll _ y => TAll _ (fun v => flattenT _ (y (TVar v)))
- | TApp _ _ x y => TApp (flattenT _ x) (flattenT _ y)
+ | TAll _ y => TAll _ (fun v => flattenT (y (TVar v)))
+ | TApp _ _ x y => TApp (flattenT x) (flattenT y)
| TCon tc => TCon tc
- | TCoerc _ t1 t2 t => TCoerc (flattenT _ t1) (flattenT _ t2) (flattenT _ t)
+ | TCoerc _ t1 t2 t => TCoerc (flattenT t1) (flattenT t2) (flattenT t)
| TArrow => TArrow
- | TCode v e => TCode (flattenT _ v) (flattenT _ e)
- | TyFunApp tfc lt => TyFunApp tfc (flattenTyFunApp _ lt)
+ | TCode v e => TCode (flattenT v) (flattenT e)
+ | TyFunApp tfc kl k lt => TyFunApp tfc kl k (flattenTyFunApp _ lt)
end
with flattenTyFunApp (lk:list Kind)(exp:@RawHaskTypeList (fun k => RawHaskType TV k) lk) : @RawHaskTypeList TV lk :=
match exp in @RawHaskTypeList _ LK return @RawHaskTypeList TV LK with
| TyFunApp_nil => TyFunApp_nil
- | TyFunApp_cons κ kl t rest => TyFunApp_cons _ _ (flattenT _ t) (flattenTyFunApp _ rest)
- end
- for flattenT) _ (exp (fun k => RawHaskType TV k) (ilmap (fun κ tv => TVar tv) env) (v TV env)).
+ | TyFunApp_cons κ kl t rest => TyFunApp_cons _ _ (flattenT t) (flattenTyFunApp _ rest)
+ end.
+End Flatten.
+
+(* PHOAS substitution on types *)
+Definition substT {Γ}{κ₁}{κ₂}(exp:forall TV (env:@InstantiatedTypeEnv TV Γ), TV κ₁ -> RawHaskType TV κ₂)(v:@HaskType Γ κ₁)
+ : @HaskType Γ κ₂ :=
+ fun TV env =>
+ flattenT (exp (fun k => RawHaskType TV k) (ilmap (fun κ tv => TVar tv) env) (v TV env)).
Notation "t @@ l" := (@mkLeveledHaskType _ _ t l) (at level 20).
Notation "t @@@ l" := (mapOptionTree (fun t' => t' @@ l) t) (at level 20).
Notation "'<[' a '|-' t ']>'" := (@HaskBrak _ a t).
+Definition getlev {Γ}(lt:LeveledHaskType Γ ★) := match lt with _ @@ l => l end.
+
Definition unlev {Γ}{κ}(lht:LeveledHaskType Γ κ) :=
match lht with t@@l => t end.
+Structure Global Γ :=
+{ glob_wv : WeakExprVar
+; glob_kinds : list Kind
+; glob_tf : IList _ (fun κ => HaskType Γ κ) glob_kinds -> HaskType Γ ★
+}.
+Coercion glob_tf : Global >-> Funclass.
+Coercion glob_wv : Global >-> WeakExprVar.
+
+(* From (t1->(t2->(t3-> ... t))), return t1::t2::t3::...nil *)
+(* this is a billion times uglier than it needs to be as a result of how primitive Coq's termiation checker is *)
+Fixpoint take_arg_types {TV}{κ}(exp: RawHaskType TV κ) {struct exp} : list (RawHaskType TV κ) :=
+ match exp as E in RawHaskType _ K return list (RawHaskType _ K) with
+ | TApp κ₁ κ₂ x y =>
+ (match κ₁ as K1 return RawHaskType TV (κ₂ ⇛ K1) -> list (RawHaskType TV κ₂) -> list (RawHaskType _ K1) with
+ | KindStar =>
+ match κ₂ as K2 return RawHaskType TV (K2 ⇛ KindStar) -> list (RawHaskType TV K2) -> list (RawHaskType _ KindStar) with
+ | KindStar => fun x' =>
+ match x' return list (RawHaskType TV KindStar) -> list (RawHaskType _ KindStar) with
+ | TApp κ₁'' κ₂'' w'' x'' =>
+ match κ₂'' as K2'' return RawHaskType TV K2'' -> list (RawHaskType TV KindStar) ->
+ list (RawHaskType _ KindStar) with
+ | KindStar =>
+ match w'' with
+ | TArrow => fun a b => a::b
+ | _ => fun _ _ => nil
+ end
+ | _ => fun _ _ => nil
+ end x''
+ | _ => fun _ => nil
+ end
+ | _ => fun _ _ => nil
+ end
+ | _ => fun _ _ => nil
+ end) x (take_arg_types y)
+ | _ => nil
+ end.
+Fixpoint count_arg_types {TV}{κ}(exp: RawHaskType TV κ) {struct exp} : nat :=
+ match exp as E in RawHaskType _ K return nat with
+ | TApp κ₁ κ₂ x y =>
+ (match κ₁ as K1 return RawHaskType TV (κ₂ ⇛ K1) -> nat -> nat with
+ | KindStar =>
+ match κ₂ as K2 return RawHaskType TV (K2 ⇛ KindStar) -> nat -> nat with
+ | KindStar => fun x' =>
+ match x' return nat -> nat with
+ | TApp κ₁'' κ₂'' w'' x'' =>
+ match κ₂'' as K2'' return RawHaskType TV K2'' -> nat -> nat with
+ | KindStar =>
+ match w'' with
+ | TArrow => fun a b => S b
+ | _ => fun _ _ => 0
+ end
+ | _ => fun _ _ => 0
+ end x''
+ | _ => fun _ => 0
+ end
+ | _ => fun _ _ => 0
+ end
+ | _ => fun _ _ => 0
+ end) x (count_arg_types y)
+ | _ => 0
+ end.
+
+ Definition ite_unit : ∀ Γ, InstantiatedTypeEnv (fun _ => unit) Γ.
+ intros.
+ induction Γ.
+ apply INil.
+ apply ICons; auto.
+ apply tt.
+ Defined.
+
+Definition take_arg_type {Γ}{κ}(ht:HaskType Γ κ) : (gt (count_arg_types (ht _ (ite_unit _))) 0) -> HaskType Γ κ :=
+ fun pf =>
+ fun TV ite =>
+ match take_arg_types (ht TV ite) with
+ | nil => Prelude_error "impossible"
+ | x::y => x
+ end.
+
+(* From (t1->(t2->(t3-> ... t))), return t *)
+(* this is a billion times uglier than it needs to be as a result of how primitive Coq's termiation checker is *)
+Fixpoint drop_arg_types {TV}{κ}(exp: RawHaskType TV κ) : RawHaskType TV κ :=
+ match exp as E in RawHaskType _ K return RawHaskType _ K with
+ | TApp κ₁ κ₂ x y =>
+ let q :=
+ (match κ₁ as K1 return RawHaskType TV (κ₂ ⇛ K1) -> (RawHaskType TV κ₂) -> ??(RawHaskType _ K1) with
+ | KindStar =>
+ match κ₂ as K2 return RawHaskType TV (K2 ⇛ KindStar) -> (RawHaskType TV K2) -> ??(RawHaskType _ KindStar) with
+ | KindStar => fun x' =>
+ match x' return (RawHaskType TV KindStar) -> ??(RawHaskType _ KindStar) with
+ | TApp κ₁'' κ₂'' w'' x'' =>
+ match κ₂'' as K2'' return RawHaskType TV K2'' -> (RawHaskType TV KindStar) -> ??(RawHaskType _ KindStar) with
+ | KindStar =>
+ match w'' with
+ | TArrow => fun _ b => Some b
+ | _ => fun _ b => None
+ end
+ | _ => fun _ b => None
+ end x''
+ | _ => fun _ => None
+ end
+ | _ => fun _ _ => None
+ end
+ | _ => fun _ _ => None
+ end) x (drop_arg_types y)
+ in match q with
+ | None => TApp x y
+ | Some y => y
+ end
+ | b => b
+ end.
unfold InstantiatedCoercionEnv; simpl.
apply vec_cons; auto.
Defined.
+
(* the various "weak" functions turn a HaskXX-in-Γ into a HaskXX-in-(κ::Γ) *)
-Definition weakITE {Γ:TypeEnv}{κ}{TV}(ite:InstantiatedTypeEnv TV (κ::Γ)) : InstantiatedTypeEnv TV Γ
- := ilist_tail ite.
+Definition weakITE {Γ:TypeEnv}{κ}{TV}(ite:InstantiatedTypeEnv TV (κ::Γ)) : InstantiatedTypeEnv TV Γ := ilist_tail ite.
+Definition weakCE {Γ:TypeEnv}{κ}(Δ:CoercionEnv Γ) : CoercionEnv (κ::Γ) := map (fun x => (fun tv ite => x tv (weakITE ite))) Δ.
+Definition weakV {Γ:TypeEnv}{κ}{κv}(cv':HaskTyVar Γ κv) : HaskTyVar (κ::Γ) κv := fun TV ite => (cv' TV (weakITE ite)).
+Definition weakT {Γ:TypeEnv}{κ}{κ₂}(lt:HaskType Γ κ₂) : HaskType (κ::Γ) κ₂ := fun TV ite => lt TV (weakITE ite).
+Definition weakL {Γ}{κ}(lt:HaskLevel Γ) : HaskLevel (κ::Γ) := map weakV lt.
+Definition weakLT {Γ}{κ}{κ₂}(lt:LeveledHaskType Γ κ₂) : LeveledHaskType (κ::Γ) κ₂ := match lt with t @@ l => weakT t @@ weakL l end.
+Definition weakICE {Γ:TypeEnv}{κ}{Δ:CoercionEnv Γ}{TV}{CV}(ice:InstantiatedCoercionEnv TV CV (κ::Γ) (weakCE Δ))
+ : InstantiatedCoercionEnv TV CV Γ Δ.
+ intros.
+ unfold InstantiatedCoercionEnv; intros.
+ unfold InstantiatedCoercionEnv in ice.
+ unfold weakCE in ice.
+ simpl in ice.
+ rewrite <- map_preserves_length in ice.
+ apply ice.
+ Defined.
+Definition weakCK {Γ}{κ}(hck:HaskCoercionKind Γ) : HaskCoercionKind (κ::Γ).
+ unfold HaskCoercionKind in *.
+ intros.
+ apply hck; clear hck.
+ inversion X; subst; auto.
+ Defined.
+Definition weakCV {Γ}{Δ}{κ}(cv':HaskCoVar Γ Δ) : HaskCoVar (κ::Γ) (weakCE Δ) :=
+ fun TV CV ite ice => (cv' TV CV (weakITE ite) (weakICE ice)).
+Definition weakF {Γ:TypeEnv}{κ}{κ₂}(f:forall TV (env:@InstantiatedTypeEnv TV Γ), TV κ -> RawHaskType TV κ₂) :
+ forall TV (env:@InstantiatedTypeEnv TV (κ::Γ)), TV κ -> RawHaskType TV κ₂
+ := fun TV ite tv => (f TV (weakITE ite) tv).
+
+
Definition weakITE' {Γ:TypeEnv}{κ}{TV}(ite:InstantiatedTypeEnv TV (app κ Γ)) : InstantiatedTypeEnv TV Γ.
induction κ; auto. apply IHκ. inversion ite; subst. apply X0. Defined.
-Definition weakCE {Γ:TypeEnv}{κ}(Δ:CoercionEnv Γ) : CoercionEnv (κ::Γ)
- := map (fun x => (fun tv ite => x tv (weakITE ite))) Δ.
-Definition weakV {Γ:TypeEnv}{κ}{κv}(cv':HaskTyVar Γ κv) : HaskTyVar (κ::Γ) κv
- := fun TV ite => (cv' TV (weakITE ite)).
Definition weakV' {Γ:TypeEnv}{κ}{κv}(cv':HaskTyVar Γ κv) : HaskTyVar (app κ Γ) κv.
induction κ; auto. apply weakV; auto. Defined.
-Definition weakT {Γ:TypeEnv}{κ}{κ₂}(lt:HaskType Γ κ₂) : HaskType (κ::Γ) κ₂
- := fun TV ite => lt TV (weakITE ite).
-Definition weakL {Γ}{κ}(lt:HaskLevel Γ) : HaskLevel (κ::Γ)
- := map weakV lt.
Definition weakT' {Γ}{κ}{κ₂}(lt:HaskType Γ κ₂) : HaskType (app κ Γ) κ₂.
induction κ; auto. apply weakT; auto. Defined.
Definition weakT'' {Γ}{κ}{κ₂}(lt:HaskType Γ κ₂) : HaskType (app Γ κ) κ₂.
apply lt.
apply X.
Defined.
-Definition lamer {a}{b}{c}{κ}(lt:HaskType (app (app a b) c) κ) : HaskType (app a (app b c)) κ.
- rewrite <- ass_app in lt.
- exact lt.
- Defined.
Definition weakL' {Γ}{κ}(lev:HaskLevel Γ) : HaskLevel (app κ Γ).
induction κ; auto. apply weakL; auto. Defined.
-Definition weakLT {Γ}{κ}{κ₂}(lt:LeveledHaskType Γ κ₂) : LeveledHaskType (κ::Γ) κ₂
- := match lt with t @@ l => weakT t @@ weakL l end.
Definition weakLT' {Γ}{κ}{κ₂}(lt:LeveledHaskType Γ κ₂) : LeveledHaskType (app κ Γ) κ₂
:= match lt with t @@ l => weakT' t @@ weakL' l end.
Definition weakCE' {Γ:TypeEnv}{κ}(Δ:CoercionEnv Γ) : CoercionEnv (app κ Γ).
induction κ; auto. apply weakCE; auto. Defined.
-Definition weakICE {Γ:TypeEnv}{κ}{Δ:CoercionEnv Γ}{TV}{CV}(ice:InstantiatedCoercionEnv TV CV (κ::Γ) (weakCE Δ))
- : InstantiatedCoercionEnv TV CV Γ Δ.
- intros.
- unfold InstantiatedCoercionEnv; intros.
- unfold InstantiatedCoercionEnv in ice.
- unfold weakCE in ice.
- simpl in ice.
- rewrite <- map_preserves_length in ice.
- apply ice.
- Defined.
-Definition weakCK {Γ}{κ}(hck:HaskCoercionKind Γ) : HaskCoercionKind (κ::Γ).
- unfold HaskCoercionKind in *.
- intros.
- apply hck; clear hck.
- inversion X; subst; auto.
- Defined.
Definition weakCK' {Γ}{κ}(hck:HaskCoercionKind Γ) : HaskCoercionKind (app κ Γ).
induction κ; auto.
apply weakCK.
Defined.
Definition weakCK'' {Γ}{κ}(hck:list (HaskCoercionKind Γ)) : list (HaskCoercionKind (app κ Γ)) :=
map weakCK' hck.
-Definition weakCV {Γ}{Δ}{κ}(cv':HaskCoVar Γ Δ) : HaskCoVar (κ::Γ) (weakCE Δ) :=
- fun TV CV ite ice => (cv' TV CV (weakITE ite) (weakICE ice)).
-Definition weakF {Γ:TypeEnv}{κ}{κ₂}(f:forall TV (env:@InstantiatedTypeEnv TV Γ), TV κ -> RawHaskType TV κ₂) :
- forall TV (env:@InstantiatedTypeEnv TV (κ::Γ)), TV κ -> RawHaskType TV κ₂
- := fun TV ite tv => (f TV (weakITE ite) tv).
+
+Definition weakITE_ {Γ:TypeEnv}{κ}{n}{TV}(ite:InstantiatedTypeEnv TV (list_ins n κ Γ)) : InstantiatedTypeEnv TV Γ.
+ rewrite list_ins_app in ite.
+ set (weakITE' ite) as ite'.
+ set (ilist_chop ite) as a.
+ rewrite <- (list_take_drop _ Γ n).
+ apply ilist_app; auto.
+ inversion ite'; auto.
+ Defined.
+
+Definition weakV_ {Γ:TypeEnv}{κ}{n}{κv}(cv':HaskTyVar Γ κv) : HaskTyVar (list_ins n κ Γ) κv.
+ unfold HaskTyVar; intros.
+ unfold HaskTyVar in cv'.
+ apply (cv' TV).
+ apply weakITE_ in env.
+ apply env.
+ Defined.
+
+Definition weakT_ {Γ}{κ}{n}{κ₂}(lt:HaskType Γ κ₂) : HaskType (list_ins n κ Γ) κ₂.
+ unfold HaskType; intros.
+ apply lt.
+ apply weakITE_ in X.
+ apply X.
+ Defined.
+Definition weakL_ {Γ}{κ}{n}(lev:HaskLevel Γ) : HaskLevel (list_ins n κ Γ).
+ unfold HaskLevel; intros.
+ unfold HaskLevel in lev.
+ eapply map.
+ apply weakV_.
+ apply lev.
+ Defined.
+Definition weakLT_ {Γ}{κ}{n}{κ₂}(lt:LeveledHaskType Γ κ₂) : LeveledHaskType (list_ins n κ Γ) κ₂ :=
+ match lt with t@@l => weakT_ t @@ weakL_ l end.
+Definition weakCK_ {Γ}{κ}{n}(hck:HaskCoercionKind Γ) : HaskCoercionKind (list_ins n κ Γ).
+ unfold HaskCoercionKind; intros.
+ unfold HaskCoercionKind in hck.
+ apply hck.
+ apply weakITE_ in X.
+ apply X.
+ Defined.
+Definition weakCE_ {Γ:TypeEnv}{κ}{n}(Δ:CoercionEnv Γ) : CoercionEnv (list_ins n κ Γ) := map weakCK_ Δ.
+Definition weakF_ {Γ:TypeEnv}{n}{κ}{κ₂}(f:forall TV (env:@InstantiatedTypeEnv TV Γ), TV κ -> RawHaskType TV κ₂) :
+ forall TV (env:@InstantiatedTypeEnv TV (list_ins n κ Γ)), TV κ -> RawHaskType TV κ₂.
+ intros.
+ apply f.
+ apply weakITE_ in env.
+ apply env.
+ apply X.
+ Defined.
+Definition weakCV_ {Γ}{Δ}{κ}{n}(cv':HaskCoVar Γ Δ) : HaskCoVar (list_ins n κ Γ) (weakCE_ Δ).
+ unfold HaskCoVar; intros.
+ unfold HaskCoVar in cv'.
+ apply (cv' TV).
+ apply weakITE_ in env.
+ apply env.
+ unfold InstantiatedCoercionEnv.
+ unfold InstantiatedCoercionEnv in cenv.
+ replace (length (@weakCE_ _ κ n Δ)) with (length Δ) in cenv.
+ apply cenv.
+ unfold weakCE_.
+ rewrite <- map_preserves_length.
+ reflexivity.
+ Defined.
+
+Definition FreshHaskTyVar_ {Γ}(κ:Kind) : forall {n}, HaskTyVar (list_ins n κ Γ) κ.
+ intros.
+ unfold HaskTyVar.
+ intros.
+ rewrite list_ins_app in env.
+ apply weakITE' in env.
+ inversion env; subst; auto.
+ Defined.
+
+
Fixpoint caseType0 {Γ}(lk:list Kind) :
IList _ (HaskType Γ) lk ->
; sac_numExprVars : nat
; sac_ekinds : vec Kind sac_numExTyVars
; sac_kinds := app (tyConKind tc) (vec2list sac_ekinds)
-; sac_Γ := fun Γ => app (vec2list sac_ekinds) Γ
-; sac_coercions : forall Γ (atypes:IList _ (HaskType Γ) (tyConKind tc)), vec (HaskCoercionKind (sac_Γ Γ)) sac_numCoerVars
-; sac_types : forall Γ (atypes:IList _ (HaskType Γ) (tyConKind tc)), vec (HaskType (sac_Γ Γ) ★) sac_numExprVars
-; sac_Δ := fun Γ (atypes:IList _ (HaskType Γ) (tyConKind tc)) Δ => app (vec2list (sac_coercions Γ atypes)) Δ
+; sac_gamma := fun Γ => app (vec2list sac_ekinds) Γ
+; sac_coercions : forall Γ (atypes:IList _ (HaskType Γ) (tyConKind tc)), vec (HaskCoercionKind (sac_gamma Γ)) sac_numCoerVars
+; sac_types : forall Γ (atypes:IList _ (HaskType Γ) (tyConKind tc)), vec (HaskType (sac_gamma Γ) ★) sac_numExprVars
+; sac_delta := fun Γ (atypes:IList _ (HaskType Γ) (tyConKind tc)) Δ => app (vec2list (sac_coercions Γ atypes)) Δ
}.
Coercion sac_tc : StrongAltCon >-> TyCon.
Coercion sac_altcon : StrongAltCon >-> WeakAltCon.
Notation "a ∼∼∼ b" := (@mkHaskCoercionKind _ _ a b) (at level 18).
-Fixpoint update_ξ
+Fixpoint update_xi
`{EQD_VV:EqDecidable VV}{Γ}
(ξ:VV -> LeveledHaskType Γ ★)
(lev:HaskLevel Γ)
: VV -> LeveledHaskType Γ ★ :=
match vt with
| nil => ξ
- | (v,τ)::tl => fun v' => if eqd_dec v v' then τ @@ lev else (update_ξ ξ lev tl) v'
+ | (v,τ)::tl => fun v' => if eqd_dec v v' then τ @@ lev else (update_xi ξ lev tl) v'
end.
-Lemma update_ξ_lemma0 `{EQD_VV:EqDecidable VV} : forall Γ ξ (lev:HaskLevel Γ)(varstypes:list (VV*_)) v,
+Lemma update_xi_lemma0 `{EQD_VV:EqDecidable VV} : forall Γ ξ (lev:HaskLevel Γ)(varstypes:list (VV*_)) v,
not (In v (map (@fst _ _) varstypes)) ->
- (update_ξ ξ lev varstypes) v = ξ v.
+ (update_xi ξ lev varstypes) v = ξ v.
intros.
induction varstypes.
reflexivity.
| TArrow => match t2 with TArrow => true | _ => false end
| TCode ec t => match t2 with TCode ec' t' => if compareT n ec ec' then compareT n t t' else false | _ => false end
| TCoerc _ t1 t2 t => match t2 with TCoerc _ t1' t2' t' => compareT n t1 t1' && compareT n t2 t2' && compareT n t t' | _ =>false end
-| TyFunApp tfc lt => match t2 with TyFunApp tfc' lt' => eqd_dec tfc tfc' && compareTL n lt lt' | _ => false end
+| TyFunApp tfc kl k lt => match t2 with TyFunApp tfc' kl' k' lt' => eqd_dec tfc tfc' && compareTL n lt lt' | _ => false end
end
with compareTL (n:nat){κ₁}(t1:@RawHaskTypeList (fun _ => nat) κ₁){κ₂}(t2:@RawHaskTypeList (fun _ => nat) κ₂) : bool :=
match t1 with
in "(forall "+++ alpha +++ ":"+++ toString k +++")"+++
typeToString' false (S n) (f n)
| TCode ec t => "<["+++(typeToString' true n t)+++"]>@"+++(typeToString' false n ec)
- | TyFunApp tfc lt => toString tfc+++ "_" +++ toString n+++" ["+++
+ | TyFunApp tfc kl k lt => toString tfc+++ "_" +++ toString n+++" ["+++
(fold_left (fun x y => " \ "+++x+++y) (typeList2string false n lt) "")+++"]"
end
with typeList2string (needparens:bool)(n:nat){κ}(t:RawHaskTypeList κ) {struct t} : list string :=
Instance TypeToStringInstance {Γ} {κ} : ToString (HaskType Γ κ) :=
{ toString := typeToString }.
+
+Definition TBool {Γ} : HaskType Γ ★ := fun TV ite => TyFunApp BoolTyCon _ _ TyFunApp_nil.
+Definition TInt {Γ} : HaskType Γ ★ := fun TV ite => TyFunApp IntTyCon _ _ TyFunApp_nil.
--- /dev/null
+(*********************************************************************************************************************************)
+(* HaskTyCons: representation of type constructors, type functions, and data constructors *)
+(*********************************************************************************************************************************)
+
+Generalizable All Variables.
+Require Import Preamble.
+Require Import General.
+Require Import Coq.Strings.String.
+Require Import HaskKinds.
+
+Variable CoreDataCon : Type. Extract Inlined Constant CoreDataCon => "DataCon.DataCon".
+
+(* once again, we pull the trick of having multiple Coq types map to a single Haskell type to provide stronger typing *)
+Variable TyCon : Type. Extract Inlined Constant TyCon => "TyCon.TyCon".
+Variable TyFun : Type. Extract Inlined Constant TyFun => "TyCon.TyCon".
+
+Variable CoreName : Type. Extract Inlined Constant CoreName => "Name.Name".
+Variable Class_ : Type. Extract Inlined Constant Class_ => "Class.Class".
+Variable CoreIPName : Type -> Type. Extract Constant CoreIPName "’a" => "BasicTypes.IPName".
+ Extraction Inline CoreIPName.
+
+Variable tyConToString : TyCon -> string. Extract Inlined Constant tyConToString => "outputableToString".
+Variable tyFunToString : TyFun -> string. Extract Inlined Constant tyFunToString => "outputableToString".
+Instance TyConToString : ToString TyCon := { toString := tyConToString }.
+Instance TyFunToString : ToString TyFun := { toString := tyFunToString }.
+Instance TyConToLatex : ToLatex TyCon := { toLatex := fun x => toLatex (toString x) }.
+Instance TyFunToLatex : ToLatex TyCon := { toLatex := fun x => toLatex (toString x) }.
+
+Variable ModalBoxTyCon : TyCon. Extract Inlined Constant ModalBoxTyCon => "TysWiredIn.hetMetCodeTypeTyCon".
+Variable PairTyCon : TyFun. Extract Inlined Constant PairTyCon => "TysWiredIn.pairTyCon".
+Variable UnitTyCon : TyFun. Extract Inlined Constant UnitTyCon => "TysWiredIn.unitTyCon".
+Variable IntTyCon : TyFun. Extract Inlined Constant IntTyCon => "TysWiredIn.intTyCon".
+Variable BoolTyCon : TyFun. Extract Inlined Constant BoolTyCon => "TysWiredIn.boolTyCon".
+Variable ArrowTyCon : TyCon. Extract Constant ArrowTyCon => "Type.funTyCon".
Require Import General.
Require Import Coq.Lists.List.
Require Import HaskKinds.
-Require Import HaskLiteralsAndTyCons.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
+Require Import HaskCoreVars.
Require Import HaskWeakVars.
Require Import HaskWeakTypes.
Inductive WeakExpr :=
| WEVar : WeakExprVar -> WeakExpr
| WELit : HaskLiteral -> WeakExpr
+
+(* TO DO: add a WEWhere and use the source location to detect which one the user used *)
| WELet : WeakExprVar -> WeakExpr -> WeakExpr -> WeakExpr
| WELetRec : Tree ??(WeakExprVar * WeakExpr) -> WeakExpr -> WeakExpr
| WECast : WeakExpr -> WeakCoercion -> WeakExpr
| WETyApp : WeakExpr -> WeakType -> WeakExpr
| WECoApp : WeakExpr -> WeakCoercion -> WeakExpr
| WELam : WeakExprVar -> WeakExpr -> WeakExpr
+(*
+| WEKappa : WeakExprVar -> WeakExpr -> WeakExpr
+| WEKappaApp : WeakExpr -> WeakExpr -> WeakExpr
+*)
| WETyLam : WeakTypeVar -> WeakExpr -> WeakExpr
| WECoLam : WeakCoerVar -> WeakExpr -> WeakExpr
Definition weakTypeOfLiteral (lit:HaskLiteral) : WeakType :=
(WTyCon (haskLiteralToTyCon lit)).
+(*
+Fixpoint weakExprVarOccursFree (wvf:WeakExprVar)(we:WeakExpr) : bool :=
+ match we with
+ | WEVar wv => if eqd_dec (wvf:CoreVar) (wv:CoreVar) then true else false
+ | WELit lit => false
+ | WEApp e1 e2 => weakExprVarOccursFree wvf e1 || weakExprVarOccursFree wvf e2
+ | WETyApp e t => weakExprVarOccursFree wvf e
+ | WECoApp e co => weakExprVarOccursFree wvf e
+ | WENote n e => weakExprVarOccursFree wvf e
+ | WELam ev e => if eqd_dec (wvf:CoreVar) (ev:CoreVar) then false else weakExprVarOccursFree wvf e
+ | WETyLam tv e => weakExprVarOccursFree wvf e
+ | WECoLam cv e => weakExprVarOccursFree wvf e
+ | WECast e co => weakExprVarOccursFree wvf e
+ | WEBrak v wtv e t => weakExprVarOccursFree wvf e
+ | WEEsc v wtv e t => weakExprVarOccursFree wvf e
+ | WECSP v wtv e t => weakExprVarOccursFree wvf e
+ | WELet v ebind ebody => weakExprVarOccursFree wvf ebind
+ || if eqd_dec (wvf:CoreVar) (v:CoreVar) then false else weakExprVarOccursFree wvf ebody
+ | WECase vs es tb tc tys alts =>
+ if weakExprVarOccursFree wvf es
+ then true
+ else (fix weakExprVarOccursFreeBranches (alts:Tree ??(_)) : bool :=
+ match alts with
+ | T_Leaf None => false
+ | T_Leaf (Some (_,_,_,v',e')) =>
+ if fold_left bor (map (fun v'':WeakExprVar => if eqd_dec (wvf:CoreVar) (v'':CoreVar) then true else false ) v') false
+ then false
+ else weakExprVarOccursFree wvf e'
+ | T_Branch b1 b2 => weakExprVarOccursFreeBranches b1 ||
+ weakExprVarOccursFreeBranches b2
+ end) alts
+ | WELetRec mlr e => false
+ end.
+
+(* some very simple-minded cleanups to produce "prettier" expressions *)
+Fixpoint simplifyWeakExpr (me:WeakExpr) : WeakExpr :=
+ match me with
+ | WEVar wv => WEVar wv
+ | WELit lit => WELit lit
+ | WEApp e1 e2 => WEApp (simplifyWeakExpr e1) (simplifyWeakExpr e2)
+ | WETyApp e t => WETyApp (simplifyWeakExpr e ) t
+ | WECoApp e co => CoreEApp (simplifyWeakExpr e ) co
+ | WENote n e => CoreENote n (simplifyWeakExpr e )
+ | WELam ev e => CoreELam ev (simplifyWeakExpr e )
+ | WETyLam tv e => CoreELam tv (simplifyWeakExpr e )
+ | WECoLam cv e => CoreELam cv (simplifyWeakExpr e )
+ | WECast e co => CoreECast (simplifyWeakExpr e ) co
+ | WEBrak v wtv e t => WEBrak v wtv (simplifyWeakExpr e ) t
+ | WEEsc v wtv e t => WEEsc v wtv (simplifyWeakExpr e ) t
+ | WECSP v wtv e t => WECSP v wtv (simplifyWeakExpr e ) t
+ | WELet v ebind ebody => WELet v (simplifyWeakExpr ebind) (simplifyWeakExpr ebody)
+ | WECase vs es tb tc tys alts => WECase vs es tb tc tys (* FIXME alts *)
+ (* un-letrec-ify multi branch letrecs *)
+ | WELetRec mlr e => WELetRec mlr (simplifyWeakExpr e )
+ end.
+*)
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import HaskKinds.
-Require Import HaskLiteralsAndTyCons.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
Require Import HaskCoreVars.
Require Import HaskCoreTypes.
Require Import HaskCore.
Extract Inlined Constant sortAlts => "sortAlts".
Implicit Arguments sortAlts [[a][b]].
-Variable mkUnsafeCoercion : CoreType -> CoreType -> CoreCoercion.
- Extract Inlined Constant mkUnsafeCoercion => "Coercion.mkUnsafeCoercion".
-
-(* Coercion and Type are actually the same thing in GHC, but we don't tell Coq about that. This lets us get around it. *)
-Variable coreCoercionsAreReallyTypes : CoreCoercion -> CoreType.
- Extract Inlined Constant coreCoercionsAreReallyTypes => "(\x -> x)".
-
Definition weakAltConToCoreAltCon (wa:WeakAltCon) : CoreAltCon :=
match wa with
| WeakDataAlt cdc => DataAlt cdc
end.
Definition weakCoercionToCoreCoercion (wc:WeakCoercion) : CoreCoercion :=
- mkUnsafeCoercion (weakTypeToCoreType (fst (weakCoercionTypes wc))) (weakTypeToCoreType (snd (weakCoercionTypes wc))).
+ CoreCoercionUnsafeCo (weakTypeToCoreType (fst (weakCoercionTypes wc))) (weakTypeToCoreType (snd (weakCoercionTypes wc))).
Fixpoint weakExprToCoreExpr (me:WeakExpr) : @CoreExpr CoreVar :=
match me with
| WELit lit => CoreELit lit
| WEApp e1 e2 => CoreEApp (weakExprToCoreExpr e1) (weakExprToCoreExpr e2)
| WETyApp e t => CoreEApp (weakExprToCoreExpr e ) (CoreEType (weakTypeToCoreType t))
- | WECoApp e co => CoreEApp (weakExprToCoreExpr e )
- (CoreEType (coreCoercionsAreReallyTypes (weakCoercionToCoreCoercion co)))
+ | WECoApp e co => CoreEApp (weakExprToCoreExpr e ) (CoreECoercion (weakCoercionToCoreCoercion co))
| WENote n e => CoreENote n (weakExprToCoreExpr e )
| WELam (weakExprVar ev _ ) e => CoreELam ev (weakExprToCoreExpr e )
| WETyLam (weakTypeVar tv _ ) e => CoreELam tv (weakExprToCoreExpr e )
- | WECoLam (weakCoerVar cv _ _ _) e => CoreELam cv (weakExprToCoreExpr e )
+ | WECoLam (weakCoerVar cv _ _) e => CoreELam cv (weakExprToCoreExpr e )
| WECast e co => CoreECast (weakExprToCoreExpr e ) (weakCoercionToCoreCoercion co)
| WEBrak v (weakTypeVar ec _) e t => fold_left CoreEApp
((CoreEType (TyVarTy ec))::
(weakExprToCoreExpr e)::
nil)
(CoreEVar v)
+ (*
+ | WEKappa v e => Prelude_error "FIXME: weakExprToCoreExpr case for WEKappa"
+ | WEKappaApp e1 e2 => Prelude_error "FIXME: weakExprToCoreExpr case for WEKappaApp"
+ *)
| WELet (weakExprVar v _) ve e => mkCoreLet (CoreNonRec v (weakExprToCoreExpr ve)) (weakExprToCoreExpr e)
| WECase vscrut escrut tbranches tc types alts =>
CoreECase (weakExprToCoreExpr escrut) vscrut (weakTypeToCoreType tbranches)
Require Import Coq.Lists.List.
Require Import Coq.Init.Specif.
Require Import HaskKinds.
-Require Import HaskLiteralsAndTyCons.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
Require Import HaskWeakTypes.
Require Import HaskWeakVars.
Require Import HaskWeak.
Require Import HaskStrongTypes.
Require Import HaskStrong.
Require Import HaskCoreVars.
+Require Import HaskCoreToWeak.
+Require Import HaskCoreTypes.
Open Scope string_scope.
Definition TyVarResolver Γ := forall wt:WeakTypeVar, ???(HaskTyVar Γ wt).
Definition CoVarResolver Γ Δ := forall wt:WeakCoerVar, ???(HaskCoVar Γ Δ).
-Definition upφ {Γ}(tv:WeakTypeVar)(φ:TyVarResolver Γ) : TyVarResolver ((tv:Kind)::Γ).
+Definition lamer {a}{b}{c}{κ}(lt:HaskType (app (app a b) c) κ) : HaskType (app a (app b c)) κ.
+ rewrite <- ass_app in lt.
+ exact lt.
+ Defined.
+
+Definition upPhi {Γ}(tv:WeakTypeVar)(φ:TyVarResolver Γ) : TyVarResolver ((tv:Kind)::Γ).
unfold TyVarResolver.
refine (fun tv' =>
if eqd_dec tv tv'
rewrite <- _H; apply fresh.
Defined.
-Definition upφ' {Γ}(tvs:list WeakTypeVar)(φ:TyVarResolver Γ)
+Definition upPhi2 {Γ}(tvs:list WeakTypeVar)(φ:TyVarResolver Γ)
: (TyVarResolver (app (map (fun tv:WeakTypeVar => tv:Kind) tvs) Γ)).
induction tvs.
apply φ.
simpl.
- apply upφ.
+ apply upPhi.
apply IHtvs.
Defined.
apply X.
Defined.
-Definition substφ {Γ:TypeEnv}(lk:list Kind)(θ:IList _ (fun κ => HaskType Γ κ) lk){κ} : HaskType (app lk Γ) κ -> HaskType Γ κ.
+Definition substphi {Γ:TypeEnv}(lk:list Kind)(θ:IList _ (fun κ => HaskType Γ κ) lk){κ} : HaskType (app lk Γ) κ -> HaskType Γ κ.
induction lk.
intro q; apply q.
simpl.
(* this is a StrongAltCon plus some stuff we know about StrongAltCons which we've built ourselves *)
Record StrongAltConPlusJunk {tc:TyCon} :=
{ sacpj_sac : @StrongAltCon tc
-; sacpj_φ : forall Γ (φ:TyVarResolver Γ ), (TyVarResolver (sac_Γ sacpj_sac Γ))
-; sacpj_ψ : forall Γ Δ atypes (ψ:CoVarResolver Γ Δ), CoVarResolver _ (sac_Δ sacpj_sac Γ atypes (weakCK'' Δ))
+; sacpj_phi : forall Γ (φ:TyVarResolver Γ ), (TyVarResolver (sac_gamma sacpj_sac Γ))
+; sacpj_psi : forall Γ Δ atypes (ψ:CoVarResolver Γ Δ), CoVarResolver _ (sac_delta sacpj_sac Γ atypes (weakCK'' Δ))
}.
Implicit Arguments StrongAltConPlusJunk [ ].
Coercion sacpj_sac : StrongAltConPlusJunk >-> StrongAltCon.
Definition mkPhi (lv:list WeakTypeVar)
: (TyVarResolver (map (fun x:WeakTypeVar => x:Kind) lv)).
- set (upφ'(Γ:=nil) lv emptyφ) as φ'.
- rewrite <- app_nil_end in φ'.
- apply φ'.
+ set (upPhi2(Γ:=nil) lv emptyφ) as φ2.
+ rewrite <- app_nil_end in φ2.
+ apply φ2.
Defined.
Definition dataConExKinds dc := vec_map (fun x:WeakTypeVar => (x:Kind)) (list2vec (dataConExTyVars dc)).
| WIParam _ ty => let case_WIParam := tt in Error "weakTypeToType: WIParam not implemented"
| WAppTy t1 t2 => let case_WAppTy := tt in weakTypeToType _ φ t1 >>= fun t1' => weakTypeToType _ φ t2 >>= fun t2' => _
| WTyVarTy v => let case_WTyVarTy := tt in φ v >>= fun v' => _
- | WForAllTy wtv t => let case_WForAllTy := tt in weakTypeToType _ (upφ wtv φ) t >>= fun t => _
- | WCodeTy ec tbody => let case_WCodeTy := tt in weakTypeToType _ φ tbody >>= fun tbody' => φ (@fixkind ★ ec) >>= fun ec' => _
+ | WForAllTy wtv t => let case_WForAllTy := tt in weakTypeToType _ (upPhi wtv φ) t >>= fun t => _
+ | WCodeTy ec tbody => let case_WCodeTy := tt in weakTypeToType _ φ tbody
+ >>= fun tbody' => φ (@fixkind ECKind ec) >>= fun ec' => _
| WCoFunTy t1 t2 t3 => let case_WCoFunTy := tt in
weakTypeToType _ φ t1 >>= fun t1' =>
weakTypeToType _ φ t2 >>= fun t2' =>
end
| tx::lt' => weakTypeToType Γ φ tx >>= fun t' =>
match lk as LK return ???(forall TV (ite:InstantiatedTypeEnv TV Γ), @RawHaskTypeList TV LK) with
- | nil => Error "WTyFunApp applied to too many types"
+ | nil => Error ("WTyFunApp applied to too many types"(* +++ eol +++
+ " tyCon= " +++ toString tc +++ eol +++
+ " tyConKindArgs= " +++ toString (fst (tyFunKind tc)) +++ eol +++
+ " tyConKindResult= " +++ toString (snd (tyFunKind tc)) +++ eol +++
+ " types= " +++ toString lt +++ eol*))
| k::lk' => weakTypeListToTypeList lk' lt' >>= fun rhtl' =>
let case_weakTypeListToTypeList := tt in _
end
try (matchThings k1'1 k2' "Kind mismatch in WAppTy: ";
subst; apply OK; apply (haskTypeOfSomeKind (fun TV env => TApp (t1' TV env) (t2' TV env))));
apply (Error ("Kind mismatch in WAppTy: "+++err)).
-
+
destruct case_weakTypeListToTypeList.
apply (addErrorMessage "case_weakTypeListToTypeList").
destruct t' as [ k' t' ].
apply OK.
eapply haskTypeOfSomeKind.
unfold HaskType; intros.
- apply TyFunApp.
+ apply (TyFunApp tc (fst (tyFunKind tc)) (snd (tyFunKind tc))).
apply lt'.
apply X.
intro ct.
apply (addErrorMessage "weakTypeToType'").
set (ilmap (@weakT' _ (vec2list (dataConExKinds dc))) avars) as avars'.
- set (@substφ _ _ avars') as q.
- set (upφ' (tyConTyVars tc) (mkPhi (dataConExTyVars dc))) as φ'.
- set (@weakTypeToType _ φ' ct) as t.
+ set (@substphi _ _ avars') as q.
+ set (upPhi2 (tyConTyVars tc) (mkPhi (dataConExTyVars dc))) as φ2.
+ set (@weakTypeToType _ φ2 ct) as t.
destruct t as [|t]; try apply (Error error_message).
destruct t as [tk t].
matchThings tk ★ "weakTypeToType'".
Definition mkStrongAltConPlusJunk : StrongAltConPlusJunk tc.
refine
{| sacpj_sac := mkStrongAltCon
- ; sacpj_φ := fun Γ φ => (fun htv => φ htv >>= fun htv' => OK (weakV' htv'))
- ; sacpj_ψ :=
+ ; sacpj_phi := fun Γ φ => (fun htv => φ htv >>= fun htv' => OK (weakV' htv'))
+ ; sacpj_psi :=
fun Γ Δ avars ψ => (fun htv => ψ htv >>= fun htv' => OK (_ (weakCV' (vec2list (sac_ekinds mkStrongAltCon)) htv')))
|}.
intro.
- unfold sac_Γ.
+ unfold sac_gamma.
unfold HaskCoVar in *.
intros.
apply (x TV CV env).
simpl in cenv.
- unfold sac_Δ in *.
+ unfold sac_delta in *.
unfold InstantiatedCoercionEnv in *.
apply vec_chop' in cenv.
apply cenv.
; sac_altcon := WeakLitAlt h
|} |}.
intro; intro φ; apply φ.
- intro; intro; intro; intro ψ. simpl. unfold sac_Γ; simpl. unfold sac_Δ; simpl.
+ intro; intro; intro; intro ψ. simpl. unfold sac_gamma; simpl. unfold sac_delta; simpl.
rewrite weakCK'_nil_inert. apply ψ.
apply OK; refine {| sacpj_sac := {|
sac_ekinds := vec_nil ; sac_coercions := fun _ _ => vec_nil ; sac_types := fun _ _ => vec_nil
; sac_altcon := WeakDEFAULT |} |}.
intro; intro φ; apply φ.
- intro; intro; intro; intro ψ. simpl. unfold sac_Γ; simpl. unfold sac_Δ; simpl.
+ intro; intro; intro; intro ψ. simpl. unfold sac_gamma; simpl. unfold sac_delta; simpl.
rewrite weakCK'_nil_inert. apply ψ.
Defined.
Variable weakCoercionToHaskCoercion : forall Γ Δ κ, WeakCoercion -> HaskCoercion Γ Δ κ.
-Definition weakψ {Γ}{Δ:CoercionEnv Γ} {κ}(ψ:WeakCoerVar -> ???(HaskCoVar Γ Δ)) :
+Definition weakPsi {Γ}{Δ:CoercionEnv Γ} {κ}(ψ:WeakCoerVar -> ???(HaskCoVar Γ Δ)) :
WeakCoerVar -> ???(HaskCoVar Γ (κ::Δ)).
intros.
refine (ψ X >>= _).
Defined.
(* attempt to "cast" an expression by simply checking if it already had the desired type, and failing otherwise *)
-Definition castExpr (we:WeakExpr)(err_msg:string) {Γ} {Δ} {ξ} {τ} τ' (e:@Expr _ CoreVarEqDecidable Γ Δ ξ τ)
- : ???(@Expr _ CoreVarEqDecidable Γ Δ ξ τ').
+Definition castExpr (we:WeakExpr)(err_msg:string) {Γ} {Δ} {ξ} {τ} {l} τ' l' (e:@Expr _ CoreVarEqDecidable Γ Δ ξ τ l)
+ : ???(@Expr _ CoreVarEqDecidable Γ Δ ξ τ' l').
apply (addErrorMessage ("castExpr " +++ err_msg)).
intros.
- destruct τ as [τ l].
- destruct τ' as [τ' l'].
destruct (eqd_dec l l'); [ idtac
| apply (Error ("level mismatch in castExpr, invoked by "+++err_msg+++eol+++
" got: " +++(fold_left (fun x y => y+++","+++y) (map (toString ○ haskTyVarToType) l) "")+++eol+++
Defined.
Definition coVarKind (wcv:WeakCoerVar) : Kind :=
- match wcv with weakCoerVar _ κ _ _ => κ end.
+ match wcv with weakCoerVar _ t _ => (kindOfCoreType (weakTypeToCoreType t)) end.
Coercion coVarKind : WeakCoerVar >-> Kind.
Definition weakTypeToTypeOfKind : forall {Γ:TypeEnv}(φ:TyVarResolver Γ)(t:WeakType)(κ:Kind), ???(HaskType Γ κ).
| WELet cv e1 e2 => doesWeakVarOccur wev e1 || (if eqd_dec (wev:CoreVar) (cv:CoreVar)then false else doesWeakVarOccur wev e2)
| WEApp e1 e2 => doesWeakVarOccur wev e1 || doesWeakVarOccur wev e2
| WELam cv e => if eqd_dec (wev:CoreVar) (cv:CoreVar) then false else doesWeakVarOccur wev e
+(*
+ | WEKappaApp e1 e2 => doesWeakVarOccur wev e1 || doesWeakVarOccur wev e2
+ | WEKappa cv e => if eqd_dec (wev:CoreVar) (cv:CoreVar) then false else doesWeakVarOccur wev e
+*)
| WETyLam cv e => doesWeakVarOccur wev e
| WECoLam cv e => doesWeakVarOccur wev e
| WECase vscrut escrut tbranches tc avars alts =>
| T_Branch b1 b2 => doesWeakVarOccurAlts wev b1 || doesWeakVarOccurAlts wev b2
end.
-(*Definition ensureCaseBindersAreNotUsed (we:WeakExpr) : UniqM WeakExpr := FIXME *)
+Definition checkDistinct :
+ forall {V}(EQ:EqDecidable V)(lv:list V), ???(distinct lv).
+ intros.
+ set (distinct_decidable lv) as q.
+ destruct q.
+ exact (OK d).
+ exact (Error "checkDistinct failed").
+ Defined.
+
+(* FIXME: check the kind of the type of the weakexprvar to support >0 *)
+Definition mkGlobal Γ (τ:HaskType Γ ★) (wev:WeakExprVar) : Global Γ.
+ refine {| glob_kinds := nil |}.
+ apply wev.
+ intros.
+ apply τ.
+ Defined.
Definition weakExprToStrongExpr : forall
(Γ:TypeEnv)
(ig:CoreVar -> bool)
(τ:HaskType Γ ★)
(lev:HaskLevel Γ),
- WeakExpr -> ???(@Expr _ CoreVarEqDecidable Γ Δ ξ (τ @@ lev) ).
+ WeakExpr -> ???(@Expr _ CoreVarEqDecidable Γ Δ ξ τ lev ).
refine ((
fix weakExprToStrongExpr
(Γ:TypeEnv)
(ig:CoreVar -> bool)
(τ:HaskType Γ ★)
(lev:HaskLevel Γ)
- (we:WeakExpr) : ???(@Expr _ CoreVarEqDecidable Γ Δ ξ (τ @@ lev) ) :=
+ (we:WeakExpr) : ???(@Expr _ CoreVarEqDecidable Γ Δ ξ τ lev ) :=
addErrorMessage ("in weakExprToStrongExpr " +++ toString we)
match we with
| WEVar v => if ig v
- then OK (EGlobal Γ Δ ξ (τ@@lev) v)
- else castExpr we ("WEVar "+++toString (v:CoreVar)) (τ @@ lev) (EVar Γ Δ ξ v)
+ then OK ((EGlobal Γ Δ ξ (mkGlobal Γ τ v) INil lev) : Expr Γ Δ ξ τ lev)
+ else castExpr we ("WEVar "+++toString (v:CoreVar)) τ lev (EVar Γ Δ ξ v)
- | WELit lit => castExpr we ("WELit "+++toString lit) (τ @@ lev) (ELit Γ Δ ξ lit lev)
+ | WELit lit => castExpr we ("WELit "+++toString lit) τ lev (ELit Γ Δ ξ lit lev)
| WELam ev ebody => weakTypeToTypeOfKind φ ev ★ >>= fun tv =>
weakTypeOfWeakExpr ebody >>= fun tbody =>
weakTypeToTypeOfKind φ tbody ★ >>= fun tbody' =>
- let ξ' := update_ξ ξ lev (((ev:CoreVar),tv)::nil) in
+ let ξ' := update_xi ξ lev (((ev:CoreVar),tv)::nil) in
let ig' := update_ig ig ((ev:CoreVar)::nil) in
weakExprToStrongExpr Γ Δ φ ψ ξ' ig' tbody' lev ebody >>= fun ebody' =>
- castExpr we "WELam" (τ@@lev) (ELam Γ Δ ξ tv tbody' lev ev ebody')
+ castExpr we "WELam" τ lev (ELam Γ Δ ξ tv tbody' lev ev ebody')
| WEBrak _ ec e tbody => φ (`ec) >>= fun ec' =>
weakTypeToTypeOfKind φ tbody ★ >>= fun tbody' =>
weakExprToStrongExpr Γ Δ φ ψ ξ ig tbody' ((ec')::lev) e >>= fun e' =>
- castExpr we "WEBrak" (τ@@lev) (EBrak Γ Δ ξ ec' tbody' lev e')
+ castExpr we "WEBrak" τ lev (EBrak Γ Δ ξ ec' tbody' lev e')
| WEEsc _ ec e tbody => φ ec >>= fun ec'' =>
weakTypeToTypeOfKind φ tbody ★ >>= fun tbody' =>
match lev with
| nil => Error "ill-leveled escapification"
| ec'::lev' => weakExprToStrongExpr Γ Δ φ ψ ξ ig (<[ ec' |- tbody' ]>) lev' e
- >>= fun e' => castExpr we "WEEsc" (τ@@lev) (EEsc Γ Δ ξ ec' tbody' lev' e')
+ >>= fun e' => castExpr we "WEEsc" τ lev (EEsc Γ Δ ξ ec' tbody' lev' e')
end
| WECSP _ ec e tbody => Error "FIXME: CSP not supported beyond HaskWeak stage"
- | WENote n e => weakExprToStrongExpr Γ Δ φ ψ ξ ig τ lev e >>= fun e' => OK (ENote _ _ _ _ n e')
+ | WENote n e => weakExprToStrongExpr Γ Δ φ ψ ξ ig τ lev e >>= fun e' => OK (ENote _ _ _ _ _ n e')
| WELet v ve ebody => weakTypeToTypeOfKind φ v ★ >>= fun tv =>
weakExprToStrongExpr Γ Δ φ ψ ξ ig tv lev ve >>= fun ve' =>
- weakExprToStrongExpr Γ Δ φ ψ (update_ξ ξ lev (((v:CoreVar),tv)::nil))
+ weakExprToStrongExpr Γ Δ φ ψ (update_xi ξ lev (((v:CoreVar),tv)::nil))
(update_ig ig ((v:CoreVar)::nil)) τ lev ebody
>>= fun ebody' =>
OK (ELet _ _ _ tv _ lev (v:CoreVar) ve' ebody')
weakExprToStrongExpr Γ Δ φ ψ ξ ig (t2'--->τ) lev e1 >>= fun e1' =>
OK (EApp _ _ _ _ _ _ e1' e2')
- | WETyLam tv e => let φ' := upφ tv φ in
+ | WETyLam tv e => let φ2 := upPhi tv φ in
weakTypeOfWeakExpr e >>= fun te =>
- weakTypeToTypeOfKind φ' te ★ >>= fun τ' =>
- weakExprToStrongExpr _ (weakCE Δ) φ'
- (fun x => (ψ x) >>= fun y => OK (weakCV y)) (weakLT○ξ) ig _ (weakL lev) e
- >>= fun e' => castExpr we "WETyLam2" _ (ETyLam Γ Δ ξ tv (mkTAll' τ') lev e')
+ weakTypeToTypeOfKind φ2 te ★ >>= fun τ' =>
+ weakExprToStrongExpr _ (weakCE_(n:=O) Δ) φ2
+ (fun x => (ψ x) >>= fun y =>
+ OK (weakCV_ y)) (weakLT_○ξ) ig _ (weakL_ lev) e
+ >>= fun e' => castExpr we "WETyLam2" _ _
+ (ETyLam Γ Δ ξ tv (mkTAll' τ') lev 0 e')
| WETyApp e t => weakTypeOfWeakExpr e >>= fun te =>
match te with
| WForAllTy wtv te' =>
- let φ' := upφ wtv φ in
- weakTypeToTypeOfKind φ' te' ★ >>= fun te'' =>
+ let φ2 := upPhi wtv φ in
+ weakTypeToTypeOfKind φ2 te' ★ >>= fun te'' =>
weakExprToStrongExpr Γ Δ φ ψ ξ ig (mkTAll te'') lev e >>= fun e' =>
weakTypeToTypeOfKind φ t (wtv:Kind) >>= fun t' =>
- castExpr we "WETyApp" _ (ETyApp Γ Δ wtv (mkTAll' te'') t' ξ lev e')
+ castExpr we "WETyApp" _ _ (ETyApp Γ Δ wtv (mkTAll' te'') t' ξ lev e')
| _ => Error ("weakTypeToType: WETyApp body with type "+++toString te)
end
weakTypeToTypeOfKind φ t2 κ >>= fun t2'' =>
weakTypeToTypeOfKind φ t3 ★ >>= fun t3'' =>
weakExprToStrongExpr Γ Δ φ ψ ξ ig (t1'' ∼∼ t2'' ⇒ τ) lev e >>= fun e' =>
- castExpr we "WECoApp" _ e' >>= fun e'' =>
+ castExpr we "WECoApp" _ _ e' >>= fun e'' =>
OK (ECoApp Γ Δ κ t1'' t2''
(weakCoercionToHaskCoercion _ _ _ co) τ ξ lev e'')
end
| _ => Error ("weakTypeToType: WECoApp body with type "+++toString te)
end
- | WECoLam cv e => let (_,_,t1,t2) := cv in
+ | WECoLam cv e => let (_,t1,t2) := cv in
weakTypeOfWeakExpr e >>= fun te =>
weakTypeToTypeOfKind φ te ★ >>= fun te' =>
weakTypeToTypeOfKind φ t1 cv >>= fun t1' =>
weakTypeToTypeOfKind φ t2 cv >>= fun t2' =>
- weakExprToStrongExpr Γ (_ :: Δ) φ (weakψ ψ) ξ ig te' lev e >>= fun e' =>
- castExpr we "WECoLam" _ (ECoLam Γ Δ cv te' t1' t2' ξ lev e')
+ weakExprToStrongExpr Γ (_ :: Δ) φ (weakPsi ψ) ξ ig te' lev e >>= fun e' =>
+ castExpr we "WECoLam" _ _ (ECoLam Γ Δ cv te' t1' t2' ξ lev e')
| WECast e co => let (t1,t2) := weakCoercionTypes co in
weakTypeToTypeOfKind φ t1 ★ >>= fun t1' =>
weakTypeToTypeOfKind φ t2 ★ >>= fun t2' =>
weakExprToStrongExpr Γ Δ φ ψ ξ ig t1' lev e >>= fun e' =>
- castExpr we "WECast" _
+ castExpr we "WECast" _ _
(ECast Γ Δ ξ t1' t2' (weakCoercionToHaskCoercion _ _ _ co) lev e')
| WELetRec rb e =>
- let ξ' := update_ξ ξ lev _ in
+ let ξ' := update_xi ξ lev _ in
let ig' := update_ig ig (map (fun x:(WeakExprVar*_) => (fst x):CoreVar) (leaves rb)) in
let binds :=
(fix binds (t:Tree ??(WeakExprVar * WeakExpr))
OK (ELR_branch Γ Δ ξ' lev _ _ b1' b2')
end) rb
in binds >>= fun binds' =>
+ checkDistinct CoreVarEqDecidable (map (@fst _ _) (leaves (varsTypes rb φ))) >>= fun rb_distinct =>
weakExprToStrongExpr Γ Δ φ ψ ξ' ig' τ lev e >>= fun e' =>
- OK (ELetRec Γ Δ ξ lev τ _ binds' e')
+ OK (ELetRec Γ Δ ξ lev τ _ _ binds' e')
| WECase vscrut escrut tbranches tc avars alts =>
weakTypeOfWeakExpr escrut >>= fun tscrut =>
weakTypeToTypeOfKind φ tbranches ★ >>= fun tbranches' =>
(fix mkTree (t:Tree ??(WeakAltCon*list WeakTypeVar*list WeakCoerVar*list WeakExprVar*WeakExpr)) : ???(Tree
??{ sac : _ & {scb : StrongCaseBranchWithVVs CoreVar CoreVarEqDecidable tc avars' sac &
- Expr (sac_Γ sac Γ) (sac_Δ sac Γ avars' (weakCK'' Δ))(scbwv_ξ scb ξ lev)(weakLT' (tbranches' @@ lev))}}) :=
+ Expr (sac_gamma sac Γ) (sac_delta sac Γ avars' (weakCK'' Δ))(scbwv_xi scb ξ lev)(weakT' tbranches')(weakL' lev)}}) :=
match t with
| T_Leaf None => OK []
| T_Leaf (Some (ac,extyvars,coervars,exprvars,ebranch)) =>
>>= fun exprvars' =>
(let case_pf := tt in _) >>= fun pf =>
let scb := @Build_StrongCaseBranchWithVVs CoreVar CoreVarEqDecidable tc Γ avars' sac exprvars' pf in
- weakExprToStrongExpr (sac_Γ sac Γ) (sac_Δ sac Γ avars' (weakCK'' Δ)) (sacpj_φ sac _ φ)
- (sacpj_ψ sac _ _ avars' ψ)
- (scbwv_ξ scb ξ lev)
+ weakExprToStrongExpr (sac_gamma sac Γ) (sac_delta sac Γ avars' (weakCK'' Δ)) (sacpj_phi sac _ φ)
+ (sacpj_psi sac _ _ avars' ψ)
+ (scbwv_xi scb ξ lev)
(update_ig ig (map (@fst _ _) (vec2list (scbwv_varstypes scb))))
(weakT' tbranches') (weakL' lev) ebranch >>= fun ebranch' =>
let case_case := tt in OK [ _ ]
end) alts >>= fun tree =>
weakExprToStrongExpr Γ Δ φ ψ ξ ig (caseType tc avars') lev escrut >>= fun escrut' =>
- castExpr we "ECase" (τ@@lev) (ECase Γ Δ ξ lev tc tbranches' avars' escrut' tree)
+ castExpr we "ECase" τ lev (ECase Γ Δ ξ lev tc tbranches' avars' escrut' tree)
end)); try clear binds; try apply ConcatenableString.
destruct case_some.
destruct (ξ c).
simpl.
apply e1.
+ rewrite mapleaves.
+ apply rb_distinct.
destruct case_pf.
set (distinct_decidable (vec2list exprvars')) as dec.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import HaskKinds.
-Require Import HaskLiteralsAndTyCons.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
Require Import HaskCoreVars.
(* a WeakTypeVar merely wraps a CoreVar and includes its Kind *)
Defined.
(* a WeakCoerVar just wraps a CoreVar and tags it with the pair of types amongst which it coerces *)
-Inductive WeakCoerVar := weakCoerVar : CoreVar -> Kind -> WeakType -> WeakType -> WeakCoerVar.
+Inductive WeakCoerVar := weakCoerVar : CoreVar -> WeakType -> WeakType -> WeakCoerVar.
Inductive WeakCoercion : Type :=
| WCoVar : WeakCoerVar -> WeakCoercion (* g *)
Fixpoint weakCoercionTypes (wc:WeakCoercion) : WeakType * WeakType :=
match wc with
-| WCoVar (weakCoerVar _ _ t1 t2) => (t1,t2)
+| WCoVar (weakCoerVar _ t1 t2) => (WFunTyCon,WFunTyCon) (* FIXME!!! *)
| WCoType t => (WFunTyCon,WFunTyCon) (* FIXME!!! *)
| WCoApp c1 c2 => (WFunTyCon,WFunTyCon) (* FIXME!!! *)
| WCoAppT c t => (WFunTyCon,WFunTyCon) (* FIXME!!! *)
Require Import Coq.Lists.List.
Require Import General.
Require Import HaskKinds.
-Require Import HaskLiteralsAndTyCons.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
Require Import HaskCoreVars.
Require Import HaskCoreTypes.
Require Import HaskWeakTypes.
+Inductive CoreVarToWeakVarResult : Type :=
+| CVTWVR_EVar : CoreType -> CoreVarToWeakVarResult
+| CVTWVR_TyVar : Kind -> CoreVarToWeakVarResult
+| CVTWVR_CoVar : CoreType -> CoreType -> CoreVarToWeakVarResult.
+
(* a WeakExprVar just wraps a CoreVar and tags it with the type of its value *)
Inductive WeakExprVar := weakExprVar : CoreVar -> WeakType -> WeakExprVar.
Definition weakVarToCoreVar (wv:WeakVar) : CoreVar :=
match wv with
- | WExprVar (weakExprVar v _ ) => v
- | WTypeVar (weakTypeVar v _ ) => v
- | WCoerVar (weakCoerVar v _ _ _) => v
+ | WExprVar (weakExprVar v _ ) => v
+ | WTypeVar (weakTypeVar v _ ) => v
+ | WCoerVar (weakCoerVar v _ _) => v
end.
Coercion weakVarToCoreVar : WeakVar >-> CoreVar.
WTyCon (haskLiteralToTyCon lit).
Coercion haskLiteralToWeakType : HaskLiteral >-> WeakType.
-Variable coreVarToWeakVar : CoreVar -> WeakVar. Extract Inlined Constant coreVarToWeakVar => "coreVarToWeakVar".
-Variable getTyConTyVars_ : CoreTyCon -> list CoreVar. Extract Inlined Constant getTyConTyVars_ => "getTyConTyVars".
-Definition tyConTyVars (tc:CoreTyCon) :=
- filter (map (fun x => match coreVarToWeakVar x with WTypeVar v => Some v | _ => None end) (getTyConTyVars_ tc)).
- Opaque tyConTyVars.
-Definition tyConKind (tc:TyCon) : list Kind := map (fun (x:WeakTypeVar) => x:Kind) (tyConTyVars tc).
+Variable coreVarToWeakVar : CoreVar -> CoreVarToWeakVarResult. Extract Inlined Constant coreVarToWeakVar => "coreVarToWeakVar".
+Variable getTyConTyVars_ : CoreTyCon -> list CoreVar. Extract Inlined Constant getTyConTyVars_ => "getTyConTyVars".
-Variable rawTyFunKind : CoreTyCon -> Kind. Extract Inlined Constant rawTyFunKind => "(coreKindToKind . TyCon.tyConKind)".
+Variable rawTyFunKind : CoreTyCon -> ((list Kind) * Kind). Extract Inlined Constant rawTyFunKind => "rawTyFunKind".
Definition tyFunKind (tc:TyFun) : ((list Kind) * Kind) :=
- splitKind (rawTyFunKind tc).
+ rawTyFunKind tc.
Instance WeakVarToString : ToString WeakVar :=
{ toString := fun x => toString (weakVarToCoreVar x) }.
(* natural deduction: you may duplicate conclusions *)
| nd_copy : forall h, h /⋯⋯/ (h,,h)
+ (* natural deduction: you may re-order conclusions *)
+ | nd_exch : forall x y, (x,,y) /⋯⋯/ (y,,x)
+
(* natural deduction: you may write two proof trees side by side on a piece of paper -- "proof product" *)
| nd_prod : forall {h1 h2 c1 c2}
(pf1: h1 /⋯⋯/ c1 )
Hint Constructors Structural.
Hint Constructors BuiltFrom.
Hint Constructors NDPredicateClosure.
-
- Hint Extern 1 => apply nd_structural_id0.
- Hint Extern 1 => apply nd_structural_id1.
- Hint Extern 1 => apply nd_structural_cancell.
- Hint Extern 1 => apply nd_structural_cancelr.
- Hint Extern 1 => apply nd_structural_llecnac.
- Hint Extern 1 => apply nd_structural_rlecnac.
- Hint Extern 1 => apply nd_structural_assoc.
- Hint Extern 1 => apply nd_structural_cossa.
- Hint Extern 1 => apply ndpc_p.
- Hint Extern 1 => apply ndpc_prod.
- Hint Extern 1 => apply ndpc_comp.
+ Hint Unfold StructuralND.
Lemma nd_id_structural : forall sl, StructuralND (nd_id sl).
intros.
apply k.
apply scnd_weak.
eapply scnd_branch; apply k.
+ inversion k; subst; auto.
inversion k; subst.
apply (scnd_branch _ _ _ (IHnd1 X) (IHnd2 X0)).
apply IHnd2.
inversion bogus.
Defined.
- (* a "ClosedSIND" is a proof with no open hypotheses and no multi-conclusion rules *)
- Inductive ClosedSIND : Tree ??Judgment -> Type :=
- | cnd_weak : ClosedSIND []
- | cnd_rule : forall h c , ClosedSIND h -> Rule h c -> ClosedSIND c
- | cnd_branch : forall c1 c2, ClosedSIND c1 -> ClosedSIND c2 -> ClosedSIND (c1,,c2)
- .
-
- (* we can turn an SIND without hypotheses into a ClosedSIND *)
- Definition closedFromSIND h c (pn2:SIND h c)(cnd:ClosedSIND h) : ClosedSIND c.
- refine ((fix closedFromPnodes h c (pn2:SIND h c)(cnd:ClosedSIND h) {struct pn2} :=
- (match pn2 in SIND H C return H=h -> C=c -> _ with
- | scnd_weak c => let case_weak := tt in _
- | scnd_comp ht ct c pn' rule => let case_comp := tt in let qq := closedFromPnodes _ _ pn' in _
- | scnd_branch ht c1 c2 pn' pn'' => let case_branch := tt in
- let q1 := closedFromPnodes _ _ pn' in
- let q2 := closedFromPnodes _ _ pn'' in _
-
- end (refl_equal _) (refl_equal _))) h c pn2 cnd).
-
- destruct case_weak.
- intros; subst.
- apply cnd_weak.
-
- destruct case_comp.
- intros.
- clear pn2.
- apply (cnd_rule ct).
- apply qq.
- subst.
- apply cnd0.
- apply rule.
-
- destruct case_branch.
- intros.
- apply cnd_branch.
- apply q1. subst. apply cnd0.
- apply q2. subst. apply cnd0.
- Defined.
-
- (* undo the above *)
- Fixpoint closedNDtoNormalND {c}(cnd:ClosedSIND c) : ND [] c :=
- match cnd in ClosedSIND C return ND [] C with
- | cnd_weak => nd_id0
- | cnd_rule h c cndh rhc => closedNDtoNormalND cndh ;; nd_rule rhc
- | cnd_branch c1 c2 cnd1 cnd2 => nd_llecnac ;; nd_prod (closedNDtoNormalND cnd1) (closedNDtoNormalND cnd2)
- end.
-
(* Natural Deduction systems whose judgments happen to be pairs of the same type *)
Section SequentND.
Context {S:Type}. (* type of sequent components *)
Coercion cndr_sndr : ContextND_Relation >-> SequentND_Relation.
Implicit Arguments ND [ Judgment ].
-Hint Constructors Structural.
-Hint Extern 1 => apply nd_id_structural.
-Hint Extern 1 => apply ndr_builtfrom_structural.
-Hint Extern 1 => apply nd_structural_id0.
-Hint Extern 1 => apply nd_structural_id1.
-Hint Extern 1 => apply nd_structural_cancell.
-Hint Extern 1 => apply nd_structural_cancelr.
-Hint Extern 1 => apply nd_structural_llecnac.
-Hint Extern 1 => apply nd_structural_rlecnac.
-Hint Extern 1 => apply nd_structural_assoc.
-Hint Extern 1 => apply nd_structural_cossa.
-Hint Extern 1 => apply ndpc_p.
-Hint Extern 1 => apply ndpc_prod.
-Hint Extern 1 => apply ndpc_comp.
-Hint Extern 1 => apply builtfrom_refl.
-Hint Extern 1 => apply builtfrom_prod1.
-Hint Extern 1 => apply builtfrom_prod2.
-Hint Extern 1 => apply builtfrom_comp1.
-Hint Extern 1 => apply builtfrom_comp2.
-Hint Extern 1 => apply builtfrom_P.
-
-Hint Extern 1 => apply snd_inert_initial.
-Hint Extern 1 => apply snd_inert_cut.
-Hint Extern 1 => apply snd_inert_structural.
-
-Hint Extern 1 => apply cnd_inert_initial.
-Hint Extern 1 => apply cnd_inert_cut.
-Hint Extern 1 => apply cnd_inert_structural.
-Hint Extern 1 => apply cnd_inert_cnd_ant_assoc.
-Hint Extern 1 => apply cnd_inert_cnd_ant_cossa.
-Hint Extern 1 => apply cnd_inert_cnd_ant_cancell.
-Hint Extern 1 => apply cnd_inert_cnd_ant_cancelr.
-Hint Extern 1 => apply cnd_inert_cnd_ant_llecnac.
-Hint Extern 1 => apply cnd_inert_cnd_ant_rlecnac.
-Hint Extern 1 => apply cnd_inert_se_expand_left.
-Hint Extern 1 => apply cnd_inert_se_expand_right.
(* This first notation gets its own scope because it can be confusing when we're working with multiple different kinds
* of proofs. When only one kind of proof is in use, it's quite helpful though. *)
Notation "[# a #]" := (nd_rule a) : nd_scope.
Notation "a === b" := (@ndr_eqv _ _ _ _ _ a b) : nd_scope.
+Hint Constructors Structural.
+Hint Constructors ND_Relation.
+Hint Constructors BuiltFrom.
+Hint Constructors NDPredicateClosure.
+Hint Constructors ContextND_Inert.
+Hint Constructors SequentND_Inert.
+Hint Unfold StructuralND.
+
(* enable setoid rewriting *)
Open Scope nd_scope.
Open Scope pf_scope.
+Hint Extern 2 (StructuralND (nd_id _)) => apply nd_id_structural.
+Hint Extern 2 (NDPredicateClosure _ ( _ ;; _ ) ) => apply ndpc_comp.
+Hint Extern 2 (NDPredicateClosure _ ( _ ** _ ) ) => apply ndpc_prod.
+Hint Extern 2 (NDPredicateClosure (@Structural _ _) (nd_id _)) => apply nd_id_structural.
+Hint Extern 2 (BuiltFrom _ _ ( _ ;; _ ) ) => apply builtfrom_comp1.
+Hint Extern 2 (BuiltFrom _ _ ( _ ;; _ ) ) => apply builtfrom_comp2.
+Hint Extern 2 (BuiltFrom _ _ ( _ ** _ ) ) => apply builtfrom_prod1.
+Hint Extern 2 (BuiltFrom _ _ ( _ ** _ ) ) => apply builtfrom_prod2.
+
+(* Hint Constructors has failed me! *)
+Hint Extern 2 (@Structural _ _ _ _ (@nd_id0 _ _)) => apply nd_structural_id0.
+Hint Extern 2 (@Structural _ _ _ _ (@nd_id1 _ _ _)) => apply nd_structural_id1.
+Hint Extern 2 (@Structural _ _ _ _ (@nd_cancell _ _ _)) => apply nd_structural_cancell.
+Hint Extern 2 (@Structural _ _ _ _ (@nd_cancelr _ _ _)) => apply nd_structural_cancelr.
+Hint Extern 2 (@Structural _ _ _ _ (@nd_llecnac _ _ _)) => apply nd_structural_llecnac.
+Hint Extern 2 (@Structural _ _ _ _ (@nd_rlecnac _ _ _)) => apply nd_structural_rlecnac.
+Hint Extern 2 (@Structural _ _ _ _ (@nd_assoc _ _ _ _ _)) => apply nd_structural_assoc.
+Hint Extern 2 (@Structural _ _ _ _ (@nd_cossa _ _ _ _ _)) => apply nd_structural_cossa.
+
+Hint Extern 4 (NDPredicateClosure _ _) => apply ndpc_p.
+
Add Parametric Relation {jt rt ndr h c} : (h/⋯⋯/c) (@ndr_eqv jt rt ndr h c)
reflexivity proved by (@Equivalence_Reflexive _ _ (ndr_eqv_equivalence h c))
symmetry proved by (@Equivalence_Symmetric _ _ (ndr_eqv_equivalence h c))
(* useful *)
Lemma ndr_comp_right_identity : forall h c (f:h/⋯⋯/c), ndr_eqv (f ;; nd_id c) f.
- intros; apply (ndr_builtfrom_structural f); auto.
+ intros; apply (ndr_builtfrom_structural f). auto.
+ auto.
Defined.
(* useful *)
intros; apply (ndr_builtfrom_structural f); auto.
Defined.
+ Ltac nd_prod_preserves_comp_ltac P EQV :=
+ match goal with
+ [ |- context [ (?A ** ?B) ;; (?C ** ?D) ] ] =>
+ set (@ndr_prod_preserves_comp _ _ EQV _ _ A _ _ B _ C _ D) as P
+ end.
+
+ Lemma nd_swap A B C D (f:ND _ A B) (g:ND _ C D) :
+ (f ** nd_id C) ;; (nd_id B ** g) ===
+ (nd_id A ** g) ;; (f ** nd_id D).
+ setoid_rewrite <- ndr_prod_preserves_comp.
+ setoid_rewrite ndr_comp_left_identity.
+ setoid_rewrite ndr_comp_right_identity.
+ reflexivity.
+ Qed.
+
+ (* this tactical searches the environment; setoid_rewrite doesn't seem to be able to do that properly sometimes *)
+ Ltac nd_swap_ltac P EQV :=
+ match goal with
+ [ |- context [ (?F ** nd_id _) ;; (nd_id _ ** ?G) ] ] =>
+ set (@nd_swap _ _ EQV _ _ _ _ F G) as P
+ end.
+
+ Lemma nd_prod_split_left A B C D (f:ND _ A B) (g:ND _ B C) :
+ nd_id D ** (f ;; g) ===
+ (nd_id D ** f) ;; (nd_id D ** g).
+ setoid_rewrite <- ndr_prod_preserves_comp.
+ setoid_rewrite ndr_comp_left_identity.
+ reflexivity.
+ Qed.
+
+ Lemma nd_prod_split_right A B C D (f:ND _ A B) (g:ND _ B C) :
+ (f ;; g) ** nd_id D ===
+ (f ** nd_id D) ;; (g ** nd_id D).
+ setoid_rewrite <- ndr_prod_preserves_comp.
+ setoid_rewrite ndr_comp_left_identity.
+ reflexivity.
+ Qed.
+
End ND_Relation_Facts.
(* a generalization of the procedure used to build (nd_id n) from nd_id0 and nd_id1 *)
| nd_id1 h => let case_nd_id1 := tt in _
| nd_weak1 h => let case_nd_weak := tt in _
| nd_copy h => let case_nd_copy := tt in _
+ | nd_exch x y => let case_nd_exch := tt in _
| nd_prod _ _ _ _ lpf rpf => let case_nd_prod := tt in _
| nd_comp _ _ _ top bot => let case_nd_comp := tt in _
| nd_rule _ _ rule => let case_nd_rule := tt in _
destruct case_nd_id1. apply nd_id1.
destruct case_nd_weak. apply nd_weak.
destruct case_nd_copy. apply nd_copy.
+ destruct case_nd_exch. apply nd_exch.
destruct case_nd_prod. apply (nd_prod (nd_map _ _ lpf) (nd_map _ _ rpf)).
destruct case_nd_comp. apply (nd_comp (nd_map _ _ top) (nd_map _ _ bot)).
destruct case_nd_cancell. apply nd_cancell.
| nd_id1 h => let case_nd_id1 := tt in _
| nd_weak1 h => let case_nd_weak := tt in _
| nd_copy h => let case_nd_copy := tt in _
+ | nd_exch x y => let case_nd_exch := tt in _
| nd_prod _ _ _ _ lpf rpf => let case_nd_prod := tt in _
| nd_comp _ _ _ top bot => let case_nd_comp := tt in _
| nd_rule _ _ rule => let case_nd_rule := tt in _
destruct case_nd_id1. apply nd_id1.
destruct case_nd_weak. apply nd_weak.
destruct case_nd_copy. apply nd_copy.
+ destruct case_nd_exch. apply nd_exch.
destruct case_nd_prod. apply (nd_prod (nd_map' _ _ lpf) (nd_map' _ _ rpf)).
destruct case_nd_comp. apply (nd_comp (nd_map' _ _ top) (nd_map' _ _ bot)).
destruct case_nd_cancell. apply nd_cancell.
| nd_property_rule : forall h c r, P h c r -> @nd_property _ _ P h c (nd_rule r).
Hint Constructors nd_property.
-(* witnesses the fact that every Rule in a particular proof satisfies the given predicate (for ClosedSIND) *)
-Inductive cnd_property {Judgment}{Rule}(P:forall h c, @Rule h c -> Prop) : forall {c}, @ClosedSIND Judgment Rule c -> Prop :=
-| cnd_property_weak : @cnd_property _ _ P _ cnd_weak
-| cnd_property_rule : forall h c r cnd',
- P h c r ->
- @cnd_property _ _ P h cnd' ->
- @cnd_property _ _ P c (cnd_rule _ _ cnd' r)
-| cnd_property_branch :
- forall c1 c2 cnd1 cnd2,
- @cnd_property _ _ P c1 cnd1 ->
- @cnd_property _ _ P c2 cnd2 ->
- @cnd_property _ _ P _ (cnd_branch _ _ cnd1 cnd2).
-
(* witnesses the fact that every Rule in a particular proof satisfies the given predicate (for SIND) *)
Inductive scnd_property {Judgment}{Rule}(P:forall h c, @Rule h c -> Prop) : forall {h c}, @SIND Judgment Rule h c -> Prop :=
| scnd_property_weak : forall c, @scnd_property _ _ P _ _ (scnd_weak c)
| nd_copy h' => rawLatexMath indent +++
rawLatexMath "\inferrule*[Left=ndCopy]{"+++judgments2latex h+++
rawLatexMath "}{"+++judgments2latex c+++rawLatexMath "}" +++ eolL
+ | nd_exch x y => rawLatexMath indent +++
+ rawLatexMath "\inferrule*[Left=exch]{"+++judgments2latex h+++
+ rawLatexMath "}{"+++judgments2latex c+++rawLatexMath "}" +++ eolL
| nd_prod h1 h2 c1 c2 pf1 pf2 => rawLatexMath indent +++
rawLatexMath "% prod " +++ eolL +++
rawLatexMath indent +++
; pmon_assoc_ll := jud_mon_assoc_ll
}.
unfold functor_fobj; unfold fmor; simpl;
- apply Build_Pentagon; simpl; intros; apply (ndr_builtfrom_structural nd_id0); auto.
+ apply Build_Pentagon; simpl; intros; apply (ndr_builtfrom_structural nd_id0); auto 10.
unfold functor_fobj; unfold fmor; simpl;
- apply Build_Triangle; simpl; intros; apply (ndr_builtfrom_structural nd_id0); auto.
+ apply Build_Triangle; simpl; intros; apply (ndr_builtfrom_structural nd_id0); auto 10.
intros; unfold eqv; simpl; auto; reflexivity.
intros; unfold eqv; simpl; auto; reflexivity.
intros; unfold eqv; simpl; apply Judgments_Category_Commutative.
--- /dev/null
+(*********************************************************************************************************************************)
+(* NaturalDeductionContext: *)
+(* *)
+(* Manipulations of a context in natural deduction proofs. *)
+(* *)
+(*********************************************************************************************************************************)
+
+Generalizable All Variables.
+Require Import Preamble.
+Require Import General.
+Require Import NaturalDeduction.
+
+Section NaturalDeductionContext.
+
+ (* Figure 3, production $\vdash_E$, Uniform rules *)
+ Inductive Arrange {T} : Tree ??T -> Tree ??T -> Type :=
+ | AId : forall a , Arrange a a
+ | ACanL : forall a , Arrange ( [],,a ) ( a )
+ | ACanR : forall a , Arrange ( a,,[] ) ( a )
+ | AuCanL : forall a , Arrange ( a ) ( [],,a )
+ | AuCanR : forall a , Arrange ( a ) ( a,,[] )
+ | AAssoc : forall a b c , Arrange (a,,(b,,c) ) ((a,,b),,c )
+ | AuAssoc : forall a b c , Arrange ((a,,b),,c ) ( a,,(b,,c) )
+ | AExch : forall a b , Arrange ( (b,,a) ) ( (a,,b) )
+ | AWeak : forall a , Arrange ( [] ) ( a )
+ | ACont : forall a , Arrange ( (a,,a) ) ( a )
+ | ALeft : forall {h}{c} x , Arrange h c -> Arrange ( x,,h ) ( x,,c)
+ | ARight : forall {h}{c} x , Arrange h c -> Arrange ( h,,x ) ( c,,x)
+ | AComp : forall {a}{b}{c}, Arrange a b -> Arrange b c -> Arrange a c
+ .
+
+ (* "Arrange" objects are parametric in the type of the leaves of the tree *)
+ Definition arrangeMap :
+ forall {T} (Σ₁ Σ₂:Tree ??T) {R} (f:T -> R),
+ Arrange Σ₁ Σ₂ ->
+ Arrange (mapOptionTree f Σ₁) (mapOptionTree f Σ₂).
+ intros.
+ induction X; simpl.
+ apply AId.
+ apply ACanL.
+ apply ACanR.
+ apply AuCanL.
+ apply AuCanR.
+ apply AAssoc.
+ apply AuAssoc.
+ apply AExch.
+ apply AWeak.
+ apply ACont.
+ apply ALeft; auto.
+ apply ARight; auto.
+ eapply AComp; [ apply IHX1 | apply IHX2 ].
+ Defined.
+
+ (* a frequently-used Arrange - swap the middle two elements of a four-element sequence *)
+ Definition arrangeSwapMiddle {T} (a b c d:Tree ??T) :
+ Arrange ((a,,b),,(c,,d)) ((a,,c),,(b,,d)).
+ eapply AComp.
+ apply AuAssoc.
+ eapply AComp.
+ eapply ALeft.
+ eapply AComp.
+ eapply AAssoc.
+ eapply ARight.
+ apply AExch.
+ eapply AComp.
+ eapply ALeft.
+ eapply AuAssoc.
+ eapply AAssoc.
+ Defined.
+
+ (* like AExch, but works on nodes which are an Assoc away from being adjacent *)
+ Definition pivotContext {T} a b c : @Arrange T ((a,,b),,c) ((a,,c),,b) :=
+ AComp (AComp (AuAssoc _ _ _) (ALeft a (AExch c b))) (AAssoc _ _ _).
+
+ (* like AExch, but works on nodes which are an Assoc away from being adjacent *)
+ Definition pivotContext' {T} a b c : @Arrange T (a,,(b,,c)) (b,,(a,,c)) :=
+ AComp (AComp (AAssoc _ _ _) (ARight c (AExch b a))) (AuAssoc _ _ _).
+
+ Definition copyAndPivotContext {T} a b c : @Arrange T ((a,,b),,(c,,b)) ((a,,c),,b).
+ eapply AComp; [ idtac | apply (ALeft (a,,c) (ACont b)) ].
+ eapply AComp; [ idtac | apply AuAssoc ].
+ eapply AComp; [ idtac | apply (ARight b (pivotContext a b c)) ].
+ apply AAssoc.
+ Defined.
+
+ (* given any set of TreeFlags on a tree, we can Arrange all of the flagged nodes into the left subtree *)
+ Definition arrangePartition :
+ forall {T} (Σ:Tree ??T) (f:T -> bool),
+ Arrange Σ (dropT (mkFlags (liftBoolFunc false f) Σ),,( (dropT (mkFlags (liftBoolFunc false (bnot ○ f)) Σ)))).
+ intros.
+ induction Σ.
+ simpl.
+ destruct a.
+ simpl.
+ destruct (f t); simpl.
+ apply AuCanL.
+ apply AuCanR.
+ simpl.
+ apply AuCanL.
+ simpl in *.
+ eapply AComp; [ idtac | apply arrangeSwapMiddle ].
+ eapply AComp.
+ eapply ALeft.
+ apply IHΣ2.
+ eapply ARight.
+ apply IHΣ1.
+ Defined.
+
+ (* inverse of arrangePartition *)
+ Definition arrangeUnPartition :
+ forall {T} (Σ:Tree ??T) (f:T -> bool),
+ Arrange (dropT (mkFlags (liftBoolFunc false f) Σ),,( (dropT (mkFlags (liftBoolFunc false (bnot ○ f)) Σ)))) Σ.
+ intros.
+ induction Σ.
+ simpl.
+ destruct a.
+ simpl.
+ destruct (f t); simpl.
+ apply ACanL.
+ apply ACanR.
+ simpl.
+ apply ACanL.
+ simpl in *.
+ eapply AComp; [ apply arrangeSwapMiddle | idtac ].
+ eapply AComp.
+ eapply ALeft.
+ apply IHΣ2.
+ eapply ARight.
+ apply IHΣ1.
+ Defined.
+
+ (* we can decide if a tree consists exclusively of (T_Leaf None)'s *)
+ Definition decide_tree_empty : forall {T:Type}(t:Tree ??T),
+ sum { q:Tree unit & t = mapTree (fun _ => None) q } unit.
+ intro T.
+ refine (fix foo t :=
+ match t with
+ | T_Leaf x => _
+ | T_Branch b1 b2 => let b1' := foo b1 in let b2' := foo b2 in _
+ end).
+ intros.
+ destruct x.
+ right; apply tt.
+ left.
+ exists (T_Leaf tt).
+ auto.
+ destruct b1'.
+ destruct b2'.
+ destruct s.
+ destruct s0.
+ subst.
+ left.
+ exists (x,,x0).
+ reflexivity.
+ right; auto.
+ right; auto.
+ Defined.
+
+ (* if a tree is empty, we can Arrange it to [] *)
+ Definition arrangeCancelEmptyTree : forall {T}{A}(q:Tree A)(t:Tree ??T),
+ t = mapTree (fun _:A => None) q ->
+ Arrange t [].
+ intros T A q.
+ induction q; intros.
+ simpl in H.
+ rewrite H.
+ apply AId.
+ simpl in *.
+ destruct t; try destruct o; inversion H.
+ set (IHq1 _ H1) as x1.
+ set (IHq2 _ H2) as x2.
+ eapply AComp.
+ eapply ARight.
+ rewrite <- H1.
+ apply x1.
+ eapply AComp.
+ apply ACanL.
+ rewrite <- H2.
+ apply x2.
+ Defined.
+
+ (* if a tree is empty, we can Arrange it from [] *)
+ Definition arrangeUnCancelEmptyTree : forall {T}{A}(q:Tree A)(t:Tree ??T),
+ t = mapTree (fun _:A => None) q ->
+ Arrange [] t.
+ intros T A q.
+ induction q; intros.
+ simpl in H.
+ rewrite H.
+ apply AId.
+ simpl in *.
+ destruct t; try destruct o; inversion H.
+ set (IHq1 _ H1) as x1.
+ set (IHq2 _ H2) as x2.
+ eapply AComp.
+ apply AuCanL.
+ eapply AComp.
+ eapply ARight.
+ apply x1.
+ eapply AComp.
+ eapply ALeft.
+ apply x2.
+ rewrite H.
+ apply AId.
+ Defined.
+
+ (* given an Arrange from Σ₁ to Σ₂ and any predicate on tree nodes, we can construct an Arrange from (dropT Σ₁) to (dropT Σ₂) *)
+ Lemma arrangeDrop {T} pred
+ : forall (Σ₁ Σ₂: Tree ??T), Arrange Σ₁ Σ₂ -> Arrange (dropT (mkFlags pred Σ₁)) (dropT (mkFlags pred Σ₂)).
+
+ refine ((fix arrangeTake t1 t2 (arr:Arrange t1 t2) :=
+ match arr as R in Arrange A B return Arrange (dropT (mkFlags pred A)) (dropT (mkFlags pred B)) with
+ | AId a => let case_AId := tt in AId _
+ | ACanL a => let case_ACanL := tt in _
+ | ACanR a => let case_ACanR := tt in _
+ | AuCanL a => let case_AuCanL := tt in _
+ | AuCanR a => let case_AuCanR := tt in _
+ | AAssoc a b c => let case_AAssoc := tt in AAssoc _ _ _
+ | AuAssoc a b c => let case_AuAssoc := tt in AuAssoc _ _ _
+ | AExch a b => let case_AExch := tt in AExch _ _
+ | AWeak a => let case_AWeak := tt in _
+ | ACont a => let case_ACont := tt in _
+ | ALeft a b c r' => let case_ALeft := tt in ALeft _ (arrangeTake _ _ r')
+ | ARight a b c r' => let case_ARight := tt in ARight _ (arrangeTake _ _ r')
+ | AComp a b c r1 r2 => let case_AComp := tt in AComp (arrangeTake _ _ r1) (arrangeTake _ _ r2)
+ end)); clear arrangeTake; intros.
+
+ destruct case_ACanL.
+ simpl; destruct (pred None); simpl; apply ACanL.
+
+ destruct case_ACanR.
+ simpl; destruct (pred None); simpl; apply ACanR.
+
+ destruct case_AuCanL.
+ simpl; destruct (pred None); simpl; apply AuCanL.
+
+ destruct case_AuCanR.
+ simpl; destruct (pred None); simpl; apply AuCanR.
+
+ destruct case_AWeak.
+ simpl; destruct (pred None); simpl; apply AWeak.
+
+ destruct case_ACont.
+ simpl; destruct (pred None); simpl; apply ACont.
+
+ Defined.
+
+ Lemma arrangePullback' {T Q}{f:T->Q}
+ : forall (Σ₁:Tree ??Q)(Σ₂:Tree ??Q), Arrange Σ₁ Σ₂ ->
+ forall Σ₂', Σ₂ = (mapOptionTree f Σ₂') ->
+ { Σ₁' : Tree ??T & prod (Σ₁ = (mapOptionTree f Σ₁')) (Arrange Σ₁' Σ₂') }
+ .
+
+ refine ((fix arrangePullback Σ₁ Σ₂ (arr:Arrange Σ₁ Σ₂) {struct arr} :
+ forall Σ₂', Σ₂ = (mapOptionTree f Σ₂') ->
+ { Σ₁' : Tree ??T & prod (Σ₁ = (mapOptionTree f Σ₁')) (Arrange Σ₁' Σ₂') }
+ :=
+ match arr as R in Arrange A B return
+ forall Σ₂', B = (mapOptionTree f Σ₂') ->
+ { Σ₁' : Tree ??T & prod (A = (mapOptionTree f Σ₁')) (Arrange Σ₁' Σ₂') }
+ with
+ | AId a => let case_AId := tt in _
+ | ACanL a => let case_ACanL := tt in _
+ | ACanR a => let case_ACanR := tt in _
+ | AuCanL a => let case_AuCanL := tt in _
+ | AuCanR a => let case_AuCanR := tt in _
+ | AAssoc a b c => let case_AAssoc := tt in _
+ | AuAssoc a b c => let case_AuAssoc := tt in _
+ | AExch a b => let case_AExch := tt in _
+ | AWeak a => let case_AWeak := tt in _
+ | ACont a => let case_ACont := tt in _
+ | ALeft a b c r' => let case_ALeft := tt in (fun rec => _) (arrangePullback _ _ r')
+ | ARight a b c r' => let case_ARight := tt in (fun rec => _) (arrangePullback _ _ r')
+ | AComp a b c r1 r2 => let case_AComp := tt in (fun rec1 rec2 => _) (arrangePullback _ _ r1) (arrangePullback _ _ r2)
+ end)); clear arrangePullback; intros.
+
+ destruct case_AId.
+ exists Σ₂'; split.
+ subst.
+ reflexivity.
+ apply AId.
+
+ destruct case_ACanL.
+ exists ([],,Σ₂'); split.
+ subst.
+ simpl.
+ reflexivity.
+ apply ACanL.
+
+ destruct case_ACanR.
+ exists (Σ₂',,[]); split.
+ subst.
+ simpl.
+ reflexivity.
+ apply ACanR.
+
+ destruct case_AuCanL.
+ destruct Σ₂'; try destruct o; inversion H; subst.
+ eexists; split.
+ reflexivity.
+ simpl in H.
+ inversion H.
+ destruct Σ₂'1; try destruct o; inversion H2.
+ apply AuCanL.
+
+ destruct case_AuCanR.
+ destruct Σ₂'; try destruct o; inversion H; subst.
+ eexists; split.
+ reflexivity.
+ simpl in H.
+ inversion H.
+ destruct Σ₂'2; try destruct o; inversion H2.
+ apply AuCanR.
+
+ destruct case_AAssoc.
+ destruct Σ₂'; try destruct o; inversion H; subst.
+ destruct Σ₂'1; try destruct o; inversion H; subst.
+ rewrite <- mapOptionTree_distributes.
+ rewrite <- mapOptionTree_distributes.
+ eexists; split.
+ reflexivity.
+ apply AAssoc.
+
+ destruct case_AuAssoc.
+ destruct Σ₂'; try destruct o; inversion H; subst.
+ destruct Σ₂'2; try destruct o; inversion H; subst.
+ rewrite <- mapOptionTree_distributes.
+ rewrite <- mapOptionTree_distributes.
+ eexists; split.
+ reflexivity.
+ apply AuAssoc.
+
+ destruct case_AExch.
+ destruct Σ₂'; try destruct o; inversion H; subst.
+ rewrite <- mapOptionTree_distributes.
+ eexists; split.
+ reflexivity.
+ apply AExch.
+
+ destruct case_AWeak.
+ exists []; split.
+ reflexivity.
+ apply AWeak.
+
+ destruct case_ACont.
+ exists (Σ₂',,Σ₂').
+ subst; split.
+ reflexivity.
+ apply ACont.
+
+ destruct case_ALeft.
+ destruct Σ₂'; try destruct o; inversion H; subst.
+ destruct (rec _ (refl_equal _)).
+ destruct p.
+ rewrite e.
+ rewrite <- mapOptionTree_distributes.
+ eexists; split.
+ reflexivity.
+ apply ALeft.
+ apply a0.
+
+ destruct case_ARight.
+ destruct Σ₂'; try destruct o; inversion H; subst.
+ destruct (rec _ (refl_equal _)).
+ destruct p.
+ rewrite e.
+ rewrite <- mapOptionTree_distributes.
+ eexists; split.
+ reflexivity.
+ apply ARight.
+ apply a0.
+
+ destruct case_AComp.
+ destruct (rec2 _ H).
+ destruct p.
+ destruct (rec1 _ e).
+ destruct p.
+ rewrite e0.
+ eexists; split.
+ reflexivity.
+ eapply AComp.
+ apply a1.
+ apply a0.
+ Defined.
+
+ Lemma arrangePullback {T Q}{f:T->Q}
+ : forall (Σ₁:Tree ??Q)(Σ₂:Tree ??T), Arrange Σ₁ (mapOptionTree f Σ₂) ->
+ { Σ₁' : Tree ??T & prod (Σ₁ = (mapOptionTree f Σ₁')) (Arrange Σ₁' Σ₂) }.
+ intros.
+ eapply arrangePullback'.
+ apply X.
+ reflexivity.
+ Defined.
+
+ (* given an Arrange from Σ₁ to Σ₂ and any predicate on tree nodes, we can construct an Arrange from (takeT Σ₁) to (takeT Σ₂) *)
+ (*
+ Lemma arrangePullback {T} pred
+ : forall (Σ₁ Σ₂: Tree ??T), Arrange Σ₁ Σ₂ -> Arrange (takeT' (mkFlags pred Σ₁)) (takeT' (mkFlags pred Σ₂)).
+ unfold takeT'.
+ *)
+
+ (* like Arrange, but without weakening or contraction *)
+ Inductive Permutation {T} : Tree ??T -> Tree ??T -> Type :=
+ | PId : forall a , Permutation a a
+ | PCanL : forall a , Permutation ( [],,a ) ( a )
+ | PCanR : forall a , Permutation ( a,,[] ) ( a )
+ | PuCanL : forall a , Permutation ( a ) ( [],,a )
+ | PuCanR : forall a , Permutation ( a ) ( a,,[] )
+ | PAssoc : forall a b c , Permutation (a,,(b,,c) ) ((a,,b),,c )
+ | PuAssoc : forall a b c , Permutation ((a,,b),,c ) ( a,,(b,,c) )
+ | PExch : forall a b , Permutation ( (b,,a) ) ( (a,,b) )
+ | PLeft : forall {h}{c} x , Permutation h c -> Permutation ( x,,h ) ( x,,c)
+ | PRight : forall {h}{c} x , Permutation h c -> Permutation ( h,,x ) ( c,,x)
+ | PComp : forall {a}{b}{c}, Permutation a b -> Permutation b c -> Permutation a c
+ .
+ Notation "a ≈ b" := (@Permutation _ a b) (at level 30).
+ Notation "a ⊆ b" := (@Arrange _ a b) (at level 30).
+
+ Definition permuteSwapMiddle {T} (a b c d:Tree ??T) :
+ ((a,,b),,(c,,d)) ≈ ((a,,c),,(b,,d)).
+ eapply PComp.
+ apply PuAssoc.
+ eapply PComp.
+ eapply PLeft.
+ eapply PComp.
+ eapply PAssoc.
+ eapply PRight.
+ apply PExch.
+ eapply PComp.
+ eapply PLeft.
+ eapply PuAssoc.
+ eapply PAssoc.
+ Defined.
+
+ Definition permuteMap :
+ forall {T} (Σ₁ Σ₂:Tree ??T) {R} (f:T -> R),
+ Σ₁ ≈ Σ₂ ->
+ (mapOptionTree f Σ₁) ≈ (mapOptionTree f Σ₂).
+ intros.
+ induction X; simpl.
+ apply PId.
+ apply PCanL.
+ apply PCanR.
+ apply PuCanL.
+ apply PuCanR.
+ apply PAssoc.
+ apply PuAssoc.
+ apply PExch.
+ apply PLeft; auto.
+ apply PRight; auto.
+ eapply PComp; [ apply IHX1 | apply IHX2 ].
+ Defined.
+
+ (* given any set of TreeFlags on a tree, we can Arrange all of the flagged nodes into the left subtree *)
+ Definition partitionPermutation :
+ forall {T} (Σ:Tree ??T) (f:T -> bool),
+ Σ ≈ (dropT (mkFlags (liftBoolFunc false f) Σ),,( (dropT (mkFlags (liftBoolFunc false (bnot ○ f)) Σ)))).
+ intros.
+ induction Σ.
+ simpl.
+ destruct a.
+ simpl.
+ destruct (f t); simpl.
+ apply PuCanL.
+ apply PuCanR.
+ simpl.
+ apply PuCanL.
+ simpl in *.
+ eapply PComp; [ idtac | apply permuteSwapMiddle ].
+ eapply PComp.
+ eapply PLeft.
+ apply IHΣ2.
+ eapply PRight.
+ apply IHΣ1.
+ Defined.
+
+ Definition permutationToArrangement {T}{a b:Tree ??T} : a ≈ b -> a ⊆ b.
+ intro arr.
+ induction arr.
+ apply AId.
+ apply ACanL.
+ apply ACanR.
+ apply AuCanL.
+ apply AuCanR.
+ apply AAssoc.
+ apply AuAssoc.
+ apply AExch.
+ apply ALeft; apply IHarr.
+ apply ARight; apply IHarr.
+ eapply AComp.
+ apply IHarr1.
+ apply IHarr2.
+ Defined.
+
+ Definition invertPermutation {T}{a b:Tree ??T} : a ≈ b -> b ≈ a.
+ intro perm.
+ induction perm.
+ apply PId.
+ apply PuCanL.
+ apply PuCanR.
+ apply PCanL.
+ apply PCanR.
+ apply PuAssoc.
+ apply PAssoc.
+ apply PExch.
+ eapply PLeft; apply IHperm.
+ eapply PRight; apply IHperm.
+ eapply PComp.
+ apply IHperm2.
+ apply IHperm1.
+ Defined.
+
+ (*
+ Definition factorArrangementAsPermutation {T} : forall (a b:Tree ??T), a ⊆ b -> { c : _ & (c,,a) ≈ b }.
+
+ refine ((fix factor a b (arr:Arrange a b) :=
+ match arr as R in Arrange A B return
+ { c : _ & (c,,A) ≈ B }
+ with
+ | AId a => let case_AId := tt in _
+ | ACanL a => let case_ACanL := tt in _
+ | ACanR a => let case_ACanR := tt in _
+ | AuCanL a => let case_AuCanL := tt in _
+ | AuCanR a => let case_AuCanR := tt in _
+ | AAssoc a b c => let case_AAssoc := tt in _
+ | AuAssoc a b c => let case_AuAssoc := tt in _
+ | AExch a b => let case_AExch := tt in _
+ | AWeak a => let case_AWeak := tt in _
+ | ACont a => let case_ACont := tt in _
+ | ALeft a b c r' => let case_ALeft := tt in (fun r'' => _) (factor _ _ r')
+ | ARight a b c r' => let case_ARight := tt in (fun r'' => _) (factor _ _ r')
+ | AComp a b c r1 r2 => let case_AComp := tt in (fun r1' r2' => _) (factor _ _ r1) (factor _ _ r2)
+ end)); clear factor; intros.
+
+ destruct case_AId.
+ exists []. apply PCanL.
+
+ destruct case_ACanL.
+ exists [].
+ eapply PComp.
+ apply PCanL.
+ apply PCanL.
+
+ destruct case_ACanR.
+ exists [].
+ eapply PComp.
+ apply PCanL.
+ apply PCanR.
+
+ destruct case_AuCanL.
+ exists [].
+ apply PRight.
+ apply PId.
+
+ destruct case_AuCanR.
+ exists [].
+ apply PExch.
+
+ destruct case_AAssoc.
+ exists [].
+ eapply PComp.
+ eapply PCanL.
+ apply PAssoc.
+
+ destruct case_AuAssoc.
+ exists [].
+ eapply PComp.
+ eapply PCanL.
+ apply PuAssoc.
+
+ destruct case_AExch.
+ exists [].
+ eapply PComp.
+ eapply PCanL.
+ apply PExch.
+
+ destruct case_AWeak.
+ exists a0.
+ eapply PCanR.
+
+ destruct case_ACont.
+ exists [].
+ eapply PComp.
+ eapply PCanL.
+ eapply PComp.
+ eapply PLeft.
+ eapply
+
+ Defined.
+ *)
+
+End NaturalDeductionContext.
--- /dev/null
+(*********************************************************************************************************************************)
+(* PCF: *)
+(* *)
+(* An alternate representation for HaskProof which ensures that deductions on a given level are grouped into contiguous *)
+(* blocks. This representation lacks the attractive compositionality properties of HaskProof, but makes it easier to *)
+(* perform the flattening process. *)
+(* *)
+(*********************************************************************************************************************************)
+
+Generalizable All Variables.
+Require Import Preamble.
+Require Import General.
+Require Import NaturalDeduction.
+Require Import Coq.Strings.String.
+Require Import Coq.Lists.List.
+
+Require Import Algebras_ch4.
+Require Import Categories_ch1_3.
+Require Import Functors_ch1_4.
+Require Import Isomorphisms_ch1_5.
+Require Import ProductCategories_ch1_6_1.
+Require Import OppositeCategories_ch1_6_2.
+Require Import Enrichment_ch2_8.
+Require Import Subcategories_ch7_1.
+Require Import NaturalTransformations_ch7_4.
+Require Import NaturalIsomorphisms_ch7_5.
+Require Import MonoidalCategories_ch7_8.
+Require Import Coherence_ch7_8.
+
+Require Import HaskKinds.
+Require Import HaskCoreTypes.
+Require Import HaskLiterals.
+Require Import HaskTyCons.
+Require Import HaskStrongTypes.
+Require Import HaskProof.
+Require Import NaturalDeduction.
+Require Import NaturalDeductionCategory.
+
+Require Import HaskStrongTypes.
+Require Import HaskStrong.
+Require Import HaskProof.
+Require Import HaskStrongToProof.
+Require Import HaskProofToStrong.
+Require Import ProgrammingLanguage.
+
+Open Scope nd_scope.
+
+
+(*
+ * The flattening transformation. Currently only TWO-level languages are
+ * supported, and the level-1 sublanguage is rather limited.
+*
+ * This file abuses terminology pretty badly. For purposes of this file,
+ * "PCF" means "the level-1 sublanguage" and "FC" (aka System FC) means
+ * the whole language (level-0 language including bracketed level-1 terms)
+ *)
+Section PCF.
+
+ Section PCF.
+
+ Context {ndr_systemfc:@ND_Relation _ Rule}.
+ Context Γ (Δ:CoercionEnv Γ).
+
+ Definition PCFJudg (ec:HaskTyVar Γ ECKind) :=
+ @prod (Tree ??(HaskType Γ ★)) (Tree ??(HaskType Γ ★)).
+ Definition pcfjudg (ec:HaskTyVar Γ ECKind) :=
+ @pair (Tree ??(HaskType Γ ★)) (Tree ??(HaskType Γ ★)).
+
+ (* given an PCFJudg at depth (ec::depth) we can turn it into an PCFJudg
+ * from depth (depth) by wrapping brackets around everything in the
+ * succedent and repopulating *)
+ Definition brakify {ec} (j:PCFJudg ec) : Judg :=
+ match j with
+ (Σ,τ) => Γ > Δ > (Σ@@@(ec::nil)) |- (mapOptionTree (fun t => HaskBrak ec t) τ @@@ nil)
+ end.
+
+ Definition pcf_vars {Γ}(ec:HaskTyVar Γ ECKind)(t:Tree ??(LeveledHaskType Γ ★)) : Tree ??(HaskType Γ ★)
+ := mapOptionTreeAndFlatten (fun lt =>
+ match lt with t @@ l => match l with
+ | ec'::nil => if eqd_dec ec ec' then [t] else []
+ | _ => []
+ end
+ end) t.
+
+ Inductive MatchingJudgments {ec} : Tree ??(PCFJudg ec) -> Tree ??Judg -> Type :=
+ | match_nil : MatchingJudgments [] []
+ | match_branch : forall a b c d, MatchingJudgments a b -> MatchingJudgments c d -> MatchingJudgments (a,,c) (b,,d)
+ | match_leaf :
+ forall Σ τ lev,
+ MatchingJudgments
+ [((pcf_vars ec Σ) , τ )]
+ [Γ > Δ > Σ |- (mapOptionTree (HaskBrak ec) τ @@@ lev)].
+
+ Definition pcfjudg2judg ec (cj:PCFJudg ec) :=
+ match cj with (Σ,τ) => Γ > Δ > (Σ @@@ (ec::nil)) |- (τ @@@ (ec::nil)) end.
+
+ (* Rules allowed in PCF; i.e. rules we know how to turn into GArrows *)
+ (* Rule_PCF consists of the rules allowed in flat PCF: everything except *)
+ (* AppT, AbsT, AppC, AbsC, Cast, Global, and some Case statements *)
+ Inductive Rule_PCF (ec:HaskTyVar Γ ECKind)
+ : forall (h c:Tree ??(PCFJudg ec)), Rule (mapOptionTree (pcfjudg2judg ec) h) (mapOptionTree (pcfjudg2judg ec) c) -> Type :=
+ | PCF_RArrange : ∀ x y t a, Rule_PCF ec [(_, _)] [(_, _)] (RArrange Γ Δ (x@@@(ec::nil)) (y@@@(ec::nil)) (t@@@(ec::nil)) a)
+ | PCF_RLit : ∀ lit , Rule_PCF ec [ ] [ ([],[_]) ] (RLit Γ Δ lit (ec::nil))
+ | PCF_RNote : ∀ Σ τ n , Rule_PCF ec [(_,[_])] [(_,[_])] (RNote Γ Δ (Σ@@@(ec::nil)) τ (ec::nil) n)
+ | PCF_RVar : ∀ σ , Rule_PCF ec [ ] [([_],[_])] (RVar Γ Δ σ (ec::nil) )
+ | PCF_RLam : ∀ Σ tx te , Rule_PCF ec [((_,,[_]),[_])] [(_,[_])] (RLam Γ Δ (Σ@@@(ec::nil)) tx te (ec::nil) )
+
+ | PCF_RApp : ∀ Σ Σ' tx te ,
+ Rule_PCF ec ([(_,[_])],,[(_,[_])]) [((_,,_),[_])]
+ (RApp Γ Δ (Σ@@@(ec::nil))(Σ'@@@(ec::nil)) tx te (ec::nil))
+
+ | PCF_RLet : ∀ Σ Σ' σ₂ p,
+ Rule_PCF ec ([(_,[_])],,[((_,,[_]),[_])]) [((_,,_),[_])]
+ (RLet Γ Δ (Σ@@@(ec::nil)) (Σ'@@@(ec::nil)) σ₂ p (ec::nil))
+
+ | PCF_RVoid : Rule_PCF ec [ ] [([],[])] (RVoid Γ Δ )
+(*| PCF_RLetRec : ∀ Σ₁ τ₁ τ₂ , Rule_PCF (ec::nil) _ _ (RLetRec Γ Δ Σ₁ τ₁ τ₂ (ec::nil) )*)
+ | PCF_RJoin : ∀ Σ₁ Σ₂ τ₁ τ₂, Rule_PCF ec ([(_,_)],,[(_,_)]) [((_,,_),(_,,_))]
+ (RJoin Γ Δ (Σ₁@@@(ec::nil)) (Σ₂@@@(ec::nil)) (τ₁@@@(ec::nil)) (τ₂@@@(ec::nil))).
+ (* need int/boolean case *)
+ Implicit Arguments Rule_PCF [ ].
+
+ Definition PCFRule lev h c := { r:_ & @Rule_PCF lev h c r }.
+ End PCF.
+
+ Definition mkEsc Γ Δ ec (h:Tree ??(PCFJudg Γ ec))
+ : ND Rule
+ (mapOptionTree (brakify Γ Δ) h)
+ (mapOptionTree (pcfjudg2judg Γ Δ ec) h).
+ apply nd_replicate; intros.
+ destruct o; simpl in *.
+ induction t0.
+ destruct a; simpl.
+ apply nd_rule.
+ apply REsc.
+ apply nd_id.
+ apply (Prelude_error "mkEsc got multi-leaf succedent").
+ Defined.
+
+ Definition mkBrak Γ Δ ec (h:Tree ??(PCFJudg Γ ec))
+ : ND Rule
+ (mapOptionTree (pcfjudg2judg Γ Δ ec) h)
+ (mapOptionTree (brakify Γ Δ) h).
+ apply nd_replicate; intros.
+ destruct o; simpl in *.
+ induction t0.
+ destruct a; simpl.
+ apply nd_rule.
+ apply RBrak.
+ apply nd_id.
+ apply (Prelude_error "mkBrak got multi-leaf succedent").
+ Defined.
+
+ Definition pcfToND Γ Δ : forall ec h c,
+ ND (PCFRule Γ Δ ec) h c -> ND Rule (mapOptionTree (pcfjudg2judg Γ Δ ec) h) (mapOptionTree (pcfjudg2judg Γ Δ ec) c).
+ intros.
+ eapply (fun q => nd_map' _ q X).
+ intros.
+ destruct X0.
+ apply nd_rule.
+ apply x.
+ Defined.
+
+ Instance OrgPCF Γ Δ lev : @ND_Relation _ (PCFRule Γ Δ lev) :=
+ { ndr_eqv := fun a b f g => (pcfToND _ _ _ _ _ f) === (pcfToND _ _ _ _ _ g) }.
+ Admitted.
+
+ Hint Constructors Rule_Flat.
+
+ Definition PCF_Arrange {Γ}{Δ}{lev} : forall x y z, Arrange x y -> ND (PCFRule Γ Δ lev) [(x,z)] [(y,z)].
+ admit.
+ Defined.
+
+ Definition PCF_cut Γ Δ lev : forall a b c, ND (PCFRule Γ Δ lev) ([(a,b)],,[(b,c)]) [(a,c)].
+ intros.
+ destruct b.
+ destruct o.
+ destruct c.
+ destruct o.
+
+ (* when the cut is a single leaf and the RHS is a single leaf: *)
+ eapply nd_comp.
+ eapply nd_prod.
+ apply nd_id.
+ apply (PCF_Arrange [h] ([],,[h]) [h0]).
+ apply AuCanL.
+ eapply nd_comp; [ idtac | apply (PCF_Arrange ([],,a) a [h0]); apply ACanL ].
+ apply nd_rule.
+ (*
+ set (@RLet Γ Δ [] (a@@@(ec::nil)) h0 h (ec::nil)) as q.
+ exists q.
+ apply (PCF_RLet _ [] a h0 h).
+ apply (Prelude_error "cut rule invoked with [a|=[b]] [[b]|=[]]").
+ apply (Prelude_error "cut rule invoked with [a|=[b]] [[b]|=[x,,y]]").
+ apply (Prelude_error "cut rule invoked with [a|=[]] [[]|=c]").
+ apply (Prelude_error "cut rule invoked with [a|=[b,,c]] [[b,,c]|=z]").
+ *)
+ Admitted.
+
+ Instance PCF_sequents Γ Δ lev ec : @SequentND _ (PCFRule Γ Δ lev) _ (pcfjudg Γ ec) :=
+ { snd_cut := PCF_cut Γ Δ lev }.
+ apply Build_SequentND.
+ intros.
+ induction a.
+ destruct a; simpl.
+ apply nd_rule.
+ exists (RVar _ _ _ _).
+ apply PCF_RVar.
+ apply nd_rule.
+ exists (RVoid _ _ ).
+ apply PCF_RVoid.
+ eapply nd_comp.
+ eapply nd_comp; [ apply nd_llecnac | idtac ].
+ apply (nd_prod IHa1 IHa2).
+ apply nd_rule.
+ exists (RJoin _ _ _ _ _ _).
+ apply PCF_RJoin.
+ admit.
+ Defined.
+
+ Definition PCF_left Γ Δ lev a b c : ND (PCFRule Γ Δ lev) [(b,c)] [((a,,b),(a,,c))].
+ eapply nd_comp; [ apply nd_llecnac | eapply nd_comp; [ idtac | idtac ] ].
+ eapply nd_prod; [ apply snd_initial | apply nd_id ].
+ apply nd_rule.
+ set (@PCF_RJoin Γ Δ lev a b a c) as q'.
+ refine (existT _ _ _).
+ apply q'.
+ Admitted.
+
+ Definition PCF_right Γ Δ lev a b c : ND (PCFRule Γ Δ lev) [(b,c)] [((b,,a),(c,,a))].
+ eapply nd_comp; [ apply nd_rlecnac | eapply nd_comp; [ idtac | idtac ] ].
+ eapply nd_prod; [ apply nd_id | apply snd_initial ].
+ apply nd_rule.
+ set (@PCF_RJoin Γ Δ lev b a c a) as q'.
+ refine (existT _ _ _).
+ apply q'.
+ Admitted.
+
+ Instance PCF_sequent_join Γ Δ lev : @ContextND _ (PCFRule Γ Δ lev) _ (pcfjudg Γ lev) _ :=
+ { cnd_expand_left := fun a b c => PCF_left Γ Δ lev c a b
+ ; cnd_expand_right := fun a b c => PCF_right Γ Δ lev c a b }.
+
+ intros; apply nd_rule. unfold PCFRule. simpl.
+ exists (RArrange _ _ _ _ _ (AuAssoc _ _ _)).
+ apply (PCF_RArrange _ _ lev ((a,,b),,c) (a,,(b,,c)) x).
+
+ intros; apply nd_rule. unfold PCFRule. simpl.
+ exists (RArrange _ _ _ _ _ (AAssoc _ _ _)).
+ apply (PCF_RArrange _ _ lev (a,,(b,,c)) ((a,,b),,c) x).
+
+ intros; apply nd_rule. unfold PCFRule. simpl.
+ exists (RArrange _ _ _ _ _ (ACanL _)).
+ apply (PCF_RArrange _ _ lev ([],,a) _ _).
+
+ intros; apply nd_rule. unfold PCFRule. simpl.
+ exists (RArrange _ _ _ _ _ (ACanR _)).
+ apply (PCF_RArrange _ _ lev (a,,[]) _ _).
+
+ intros; apply nd_rule. unfold PCFRule. simpl.
+ exists (RArrange _ _ _ _ _ (AuCanL _)).
+ apply (PCF_RArrange _ _ lev _ ([],,a) _).
+
+ intros; apply nd_rule. unfold PCFRule. simpl.
+ exists (RArrange _ _ _ _ _ (AuCanR _)).
+ apply (PCF_RArrange _ _ lev _ (a,,[]) _).
+ Defined.
+
+ Instance OrgPCF_SequentND_Relation Γ Δ lev : SequentND_Relation (PCF_sequent_join Γ Δ lev) (OrgPCF Γ Δ lev).
+ admit.
+ Defined.
+
+ Definition OrgPCF_ContextND_Relation Γ Δ lev
+ : @ContextND_Relation _ _ _ _ _ (PCF_sequent_join Γ Δ lev) (OrgPCF Γ Δ lev) (OrgPCF_SequentND_Relation Γ Δ lev).
+ admit.
+ Defined.
+
+ (* 5.1.3 *)
+ Instance PCF Γ Δ lev : ProgrammingLanguage :=
+ { pl_cnd := PCF_sequent_join Γ Δ lev
+ ; pl_eqv := OrgPCF_ContextND_Relation Γ Δ lev
+ }.
+
+End PCF.
Require Import RepresentableStructure_ch7_2.
Require Import FunctorCategories_ch7_7.
-Require Import Enrichments.
Require Import NaturalDeduction.
-Require Import NaturalDeductionCategory.
Section Programming_Language.
Open Scope pl_scope.
Class ProgrammingLanguage :=
- { pl_eqv0 : @ND_Relation PLJudg Rule
+ { pl_eqv0 :> @ND_Relation PLJudg Rule
; pl_snd :> @SequentND PLJudg Rule _ sequent
; pl_cnd :> @ContextND PLJudg Rule T sequent pl_snd
; pl_eqv1 :> @SequentND_Relation PLJudg Rule _ sequent pl_snd pl_eqv0
; pl_eqv :> @ContextND_Relation PLJudg Rule _ sequent pl_snd pl_cnd pl_eqv0 pl_eqv1
}.
Notation "pf1 === pf2" := (@ndr_eqv _ _ pl_eqv _ _ pf1 pf2) : temporary_scope3.
-
- Section LanguageCategory.
-
- Context (PL:ProgrammingLanguage).
-
- (* category of judgments in a fixed type/coercion context *)
- Definition Judgments_cartesian := @Judgments_Category_CartesianCat _ Rule pl_eqv.
-
- Definition JudgmentsL := Judgments_cartesian.
-
- Definition identityProof t : [] ~~{JudgmentsL}~~> [t |= t].
- unfold hom; simpl.
- apply snd_initial.
- Defined.
-
- Definition cutProof a b c : [a |= b],,[b |= c] ~~{JudgmentsL}~~> [a |= c].
- unfold hom; simpl.
- apply snd_cut.
- Defined.
-
- Existing Instance pl_eqv.
-
- Definition TypesL : ECategory JudgmentsL (Tree ??T) (fun x y => [x|=y]).
- refine
- {| eid := identityProof
- ; ecomp := cutProof
- |}; intros.
- apply (mon_commutative(MonoidalCat:=JudgmentsL)).
- apply (mon_commutative(MonoidalCat:=JudgmentsL)).
- unfold identityProof; unfold cutProof; simpl; eapply cndr_inert. apply pl_eqv. auto. auto.
- unfold identityProof; unfold cutProof; simpl; eapply cndr_inert. apply pl_eqv. auto. auto.
- unfold identityProof; unfold cutProof; simpl; eapply cndr_inert. apply pl_eqv. auto. auto.
- apply ndpc_comp; auto.
- apply ndpc_comp; auto.
- Defined.
-
- Instance Types_first c : EFunctor TypesL TypesL (fun x => x,,c ) :=
- { efunc := fun x y => cnd_expand_right(ContextND:=pl_cnd) x y c }.
- intros; apply (mon_commutative(MonoidalCat:=JudgmentsL)).
- intros. unfold ehom. unfold hom. unfold identityProof. unfold eid. simpl. unfold identityProof.
- apply (cndr_inert pl_cnd); auto.
- intros. unfold ehom. unfold comp. simpl. unfold cutProof.
- rewrite <- (@ndr_prod_preserves_comp _ _ pl_eqv _ _ (cnd_expand_right _ _ c) _ _ (nd_id1 (b|=c0))
- _ (nd_id1 (a,,c |= b,,c)) _ (cnd_expand_right _ _ c)).
- setoid_rewrite (@ndr_comp_right_identity _ _ pl_eqv _ [a,, c |= b,, c]).
- setoid_rewrite (@ndr_comp_left_identity _ _ pl_eqv [b |= c0]).
- simpl; eapply cndr_inert. apply pl_eqv. auto. auto.
- Defined.
-
- Instance Types_second c : EFunctor TypesL TypesL (fun x => c,,x) :=
- { efunc := fun x y => ((@cnd_expand_left _ _ _ _ _ _ x y c)) }.
- intros; apply (mon_commutative(MonoidalCat:=JudgmentsL)).
- intros. unfold ehom. unfold hom. unfold identityProof. unfold eid. simpl. unfold identityProof.
- eapply cndr_inert; auto. apply pl_eqv.
- intros. unfold ehom. unfold comp. simpl. unfold cutProof.
- rewrite <- (@ndr_prod_preserves_comp _ _ pl_eqv _ _ (cnd_expand_left _ _ c) _ _ (nd_id1 (b|=c0))
- _ (nd_id1 (c,,a |= c,,b)) _ (cnd_expand_left _ _ c)).
- setoid_rewrite (@ndr_comp_right_identity _ _ pl_eqv _ [c,,a |= c,,b]).
- setoid_rewrite (@ndr_comp_left_identity _ _ pl_eqv [b |= c0]).
- simpl; eapply cndr_inert. apply pl_eqv. auto. auto.
- Defined.
-
- Definition Types_binoidal : EBinoidalCat TypesL (@T_Branch _).
- refine
- {| ebc_first := Types_first
- ; ebc_second := Types_second
- |}.
- Defined.
-
- Instance Types_assoc_iso a b c : Isomorphic(C:=TypesL) ((a,,b),,c) (a,,(b,,c)) :=
- { iso_forward := snd_initial _ ;; cnd_ant_cossa _ a b c
- ; iso_backward := snd_initial _ ;; cnd_ant_assoc _ a b c
- }.
- simpl; eapply cndr_inert. unfold identityProof; apply pl_eqv. auto.
- apply ndpc_comp; auto.
- apply ndpc_comp; auto.
- auto.
- simpl; eapply cndr_inert. unfold identityProof; apply pl_eqv. auto.
- apply ndpc_comp; auto.
- apply ndpc_comp; auto.
- auto.
- Defined.
-
- Instance Types_cancelr_iso a : Isomorphic(C:=TypesL) (a,,[]) a :=
- { iso_forward := snd_initial _ ;; cnd_ant_rlecnac _ a
- ; iso_backward := snd_initial _ ;; cnd_ant_cancelr _ a
- }.
- unfold eqv; unfold comp; simpl.
- eapply cndr_inert. apply pl_eqv. auto.
- apply ndpc_comp; auto.
- apply ndpc_comp; auto.
- auto.
- unfold eqv; unfold comp; simpl.
- eapply cndr_inert. apply pl_eqv. auto.
- apply ndpc_comp; auto.
- apply ndpc_comp; auto.
- auto.
- Defined.
-
- Instance Types_cancell_iso a : Isomorphic(C:=TypesL) ([],,a) a :=
- { iso_forward := snd_initial _ ;; cnd_ant_llecnac _ a
- ; iso_backward := snd_initial _ ;; cnd_ant_cancell _ a
- }.
- unfold eqv; unfold comp; simpl.
- eapply cndr_inert. apply pl_eqv. auto.
- apply ndpc_comp; auto.
- apply ndpc_comp; auto.
- auto.
- unfold eqv; unfold comp; simpl.
- eapply cndr_inert. apply pl_eqv. auto.
- apply ndpc_comp; auto.
- apply ndpc_comp; auto.
- auto.
- Defined.
-
- Instance Types_assoc a b : Types_second a >>>> Types_first b <~~~> Types_first b >>>> Types_second a :=
- { ni_iso := fun c => Types_assoc_iso a c b }.
- admit. (* need to add this as an obligation in ProgrammingLanguage class *)
- Defined.
-
- Instance Types_cancelr : Types_first [] <~~~> functor_id _ :=
- { ni_iso := Types_cancelr_iso }.
- intros; simpl.
- admit. (* need to add this as an obligation in ProgrammingLanguage class *)
- Defined.
-
- Instance Types_cancell : Types_second [] <~~~> functor_id _ :=
- { ni_iso := Types_cancell_iso }.
- admit. (* need to add this as an obligation in ProgrammingLanguage class *)
- Defined.
-
- Instance Types_assoc_ll a b : Types_second (a,,b) <~~~> Types_second b >>>> Types_second a :=
- { ni_iso := fun c => Types_assoc_iso a b c }.
- admit. (* need to add this as an obligation in ProgrammingLanguage class *)
- Defined.
-
- Instance Types_assoc_rr a b : Types_first (a,,b) <~~~> Types_first a >>>> Types_first b :=
- { ni_iso := fun c => iso_inv _ _ (Types_assoc_iso c a b) }.
- admit. (* need to add this as an obligation in ProgrammingLanguage class *)
- Defined.
-
- Instance TypesL_PreMonoidal : PreMonoidalCat Types_binoidal [] :=
- { pmon_assoc := Types_assoc
- ; pmon_cancell := Types_cancell
- ; pmon_cancelr := Types_cancelr
- ; pmon_assoc_rr := Types_assoc_rr
- ; pmon_assoc_ll := Types_assoc_ll
- }.
- apply Build_Pentagon.
- intros; simpl.
- eapply cndr_inert. apply pl_eqv.
- apply ndpc_comp.
- apply ndpc_comp.
- auto.
- apply ndpc_comp.
- apply ndpc_prod.
- apply ndpc_comp.
- apply ndpc_comp.
- auto.
- apply ndpc_comp.
- auto.
- auto.
- auto.
- auto.
- auto.
- auto.
- apply ndpc_comp.
- apply ndpc_comp.
- auto.
- apply ndpc_comp.
- auto.
- auto.
- auto.
- apply Build_Triangle; intros; simpl.
- eapply cndr_inert. apply pl_eqv.
- auto.
- apply ndpc_comp.
- apply ndpc_comp.
- auto.
- apply ndpc_comp.
- auto.
- auto.
- auto.
- eapply cndr_inert. apply pl_eqv. auto.
- auto.
- intros; simpl; reflexivity.
- intros; simpl; reflexivity.
- admit. (* assoc is central: need to add this as an obligation in ProgrammingLanguage class *)
- admit. (* cancelr is central: need to add this as an obligation in ProgrammingLanguage class *)
- admit. (* cancell is central: need to add this as an obligation in ProgrammingLanguage class *)
- Defined.
-
- Definition TypesEnrichedInJudgments : SurjectiveEnrichment.
- refine
- {| senr_c_pm := TypesL_PreMonoidal
- ; senr_v := JudgmentsL
- ; senr_v_bin := Judgments_Category_binoidal _
- ; senr_v_pmon := Judgments_Category_premonoidal _
- ; senr_v_mon := Judgments_Category_monoidal _
- ; senr_c_bin := Types_binoidal
- ; senr_c := TypesL
- |}.
- Defined.
-
- End LanguageCategory.
+ Coercion pl_eqv : ProgrammingLanguage >-> ContextND_Relation.
+ Coercion pl_cnd : ProgrammingLanguage >-> ContextND.
End Programming_Language.
-Implicit Arguments ND [ Judgment ].
+
Require Import NaturalDeduction.
Require Import NaturalDeductionCategory.
-Require Import ProgrammingLanguage.
+Require Import ProgrammingLanguageCategory.
Require Import FreydCategories.
Require Import Enrichments.
Require Import GeneralizedArrow.
--- /dev/null
+(*********************************************************************************************************************************)
+(* ProgrammingLanguageCategory *)
+(* *)
+(* The category Types(L) *)
+(* *)
+(*********************************************************************************************************************************)
+
+Generalizable All Variables.
+Require Import Preamble.
+Require Import General.
+Require Import Categories_ch1_3.
+Require Import InitialTerminal_ch2_2.
+Require Import Functors_ch1_4.
+Require Import Isomorphisms_ch1_5.
+Require Import ProductCategories_ch1_6_1.
+Require Import OppositeCategories_ch1_6_2.
+Require Import Enrichment_ch2_8.
+Require Import Subcategories_ch7_1.
+Require Import NaturalTransformations_ch7_4.
+Require Import NaturalIsomorphisms_ch7_5.
+Require Import BinoidalCategories.
+Require Import PreMonoidalCategories.
+Require Import MonoidalCategories_ch7_8.
+Require Import Coherence_ch7_8.
+Require Import Enrichment_ch2_8.
+Require Import RepresentableStructure_ch7_2.
+Require Import FunctorCategories_ch7_7.
+
+Require Import NaturalDeduction.
+Require Import ProgrammingLanguage.
+ Export ProgrammingLanguage.
+
+Require Import NaturalDeductionCategory.
+
+Open Scope nd_scope.
+(* I am at a loss to explain why "auto" can't handle this *)
+Ltac ndpc_tac :=
+ match goal with
+ | [ |- NDPredicateClosure ?P (?A ;; ?B) ] => apply ndpc_comp; ndpc_tac
+ | [ |- NDPredicateClosure ?P (?A ** ?B) ] => apply ndpc_prod; ndpc_tac
+ | _ => auto
+ end.
+
+(* this tactical searches the environment; setoid_rewrite doesn't seem to be able to do that properly sometimes *)
+Ltac nd_swap_ltac P EQV :=
+ match goal with
+ [ |- context [ (?F ** nd_id _) ;; (nd_id _ ** ?G) ] ] =>
+ set (@nd_swap _ _ EQV _ _ _ _ F G) as P
+ end.
+
+(* I still wish I knew why "Hint Constructors" doesn't work *)
+Hint Extern 5 => apply snd_inert_initial.
+Hint Extern 5 => apply snd_inert_cut.
+Hint Extern 5 => apply snd_inert_structural.
+Hint Extern 5 => apply cnd_inert_initial.
+Hint Extern 5 => apply cnd_inert_cut.
+Hint Extern 5 => apply cnd_inert_structural.
+Hint Extern 5 => apply cnd_inert_cnd_ant_assoc.
+Hint Extern 5 => apply cnd_inert_cnd_ant_cossa.
+Hint Extern 5 => apply cnd_inert_cnd_ant_cancell.
+Hint Extern 5 => apply cnd_inert_cnd_ant_cancelr.
+Hint Extern 5 => apply cnd_inert_cnd_ant_llecnac.
+Hint Extern 5 => apply cnd_inert_cnd_ant_rlecnac.
+Hint Extern 5 => apply cnd_inert_se_expand_left.
+Hint Extern 5 => apply cnd_inert_se_expand_right.
+
+Hint Extern 2 (@Structural _ _ _ _ (@nd_id _ _ [] )) => simpl; auto.
+Hint Extern 2 (@Structural _ _ _ _ (@nd_id _ _ [ _ ])) => simpl; auto.
+
+Section ProgrammingLanguageCategory.
+
+ Context {T : Type}. (* types of the language *)
+
+ Context {Rule : Tree ??(@PLJudg T) -> Tree ??(@PLJudg T) -> Type}.
+ Notation "cs |= ss" := (@sequent T cs ss) : pl_scope.
+
+ Notation "H /⋯⋯/ C" := (ND Rule H C) : pl_scope.
+
+ Open Scope pf_scope.
+ Open Scope nd_scope.
+ Open Scope pl_scope.
+
+ Context (PL:@ProgrammingLanguage T Rule).
+
+ (* category of judgments in a fixed type/coercion context *)
+ Definition Judgments_cartesian := @Judgments_Category_CartesianCat _ Rule pl_eqv.
+
+ Definition JudgmentsL := Judgments_cartesian.
+
+ Definition identityProof t : [] ~~{JudgmentsL}~~> [t |= t].
+ unfold hom; simpl.
+ apply snd_initial.
+ Defined.
+
+ Definition cutProof a b c : [a |= b],,[b |= c] ~~{JudgmentsL}~~> [a |= c].
+ unfold hom; simpl.
+ apply snd_cut.
+ Defined.
+
+ Instance TypesL : ECategory JudgmentsL (Tree ??T) (fun x y => [x|=y]) :=
+ { eid := identityProof
+ ; ecomp := cutProof
+ }.
+ intros; apply (mon_commutative(MonoidalCat:=JudgmentsL)).
+ intros; apply (mon_commutative(MonoidalCat:=JudgmentsL)).
+ abstract (intros; unfold identityProof; unfold cutProof; simpl; eapply cndr_inert; auto; apply PL).
+ abstract (intros; unfold identityProof; unfold cutProof; simpl; eapply cndr_inert; auto; apply PL).
+ abstract (intros; unfold identityProof; unfold cutProof; simpl; eapply cndr_inert;
+ [ apply PL | idtac | idtac ]; apply ndpc_comp; auto).
+ Defined.
+
+ Instance Types_first c : EFunctor TypesL TypesL (fun x => x,,c ) :=
+ { efunc := fun x y => cnd_expand_right(ContextND:=pl_cnd) x y c }.
+ intros; apply (mon_commutative(MonoidalCat:=JudgmentsL)).
+ abstract (intros; simpl; apply (cndr_inert pl_cnd); auto).
+ abstract (intros; unfold ehom; unfold comp; simpl; unfold cutProof;
+ rewrite <- (@ndr_prod_preserves_comp _ _ PL _ _ (cnd_expand_right _ _ c) _ _ (nd_id1 (b|=c0))
+ _ (nd_id1 (a,,c |= b,,c)) _ (cnd_expand_right _ _ c));
+ setoid_rewrite (@ndr_comp_right_identity _ _ PL _ [a,, c |= b,, c]);
+ setoid_rewrite (@ndr_comp_left_identity _ _ PL [b |= c0]);
+ simpl; eapply cndr_inert; [ apply PL | auto | auto ]).
+ Defined.
+
+ Instance Types_second c : EFunctor TypesL TypesL (fun x => c,,x) :=
+ { efunc := fun x y => ((@cnd_expand_left _ _ _ _ _ _ x y c)) }.
+ intros; apply (mon_commutative(MonoidalCat:=JudgmentsL)).
+ abstract (intros; simpl; apply (cndr_inert pl_cnd); auto).
+ intros; unfold ehom; unfold comp; simpl; unfold cutProof;
+ abstract (rewrite <- (@ndr_prod_preserves_comp _ _ PL _ _ (cnd_expand_left _ _ c) _ _ (nd_id1 (b|=c0))
+ _ (nd_id1 (c,,a |= c,,b)) _ (cnd_expand_left _ _ c));
+ setoid_rewrite (@ndr_comp_right_identity _ _ PL _ [c,,a |= c,,b]);
+ setoid_rewrite (@ndr_comp_left_identity _ _ PL [b |= c0]);
+ simpl; eapply cndr_inert; [ apply PL | auto | auto ]).
+ Defined.
+
+ Instance Types_binoidal : EBinoidalCat TypesL (@T_Branch _) :=
+ { ebc_first := Types_first
+ ; ebc_second := Types_second
+ }.
+
+ Instance Types_assoc_iso a b c : Isomorphic(C:=TypesL) ((a,,b),,c) (a,,(b,,c)) :=
+ { iso_forward := snd_initial _ ;; cnd_ant_cossa _ a b c
+ ; iso_backward := snd_initial _ ;; cnd_ant_assoc _ a b c
+ }.
+ abstract (simpl; eapply cndr_inert; unfold identityProof; [ apply PL | idtac | idtac ]; ndpc_tac).
+ abstract (simpl; eapply cndr_inert; unfold identityProof; [ apply PL | idtac | idtac ]; ndpc_tac).
+ Defined.
+
+ Instance Types_cancelr_iso a : Isomorphic(C:=TypesL) (a,,[]) a :=
+ { iso_forward := snd_initial _ ;; cnd_ant_rlecnac _ a
+ ; iso_backward := snd_initial _ ;; cnd_ant_cancelr _ a
+ }.
+ abstract (simpl; eapply cndr_inert; unfold identityProof; [ apply PL | idtac | idtac ]; ndpc_tac).
+ abstract (simpl; eapply cndr_inert; unfold identityProof; [ apply PL | idtac | idtac ]; ndpc_tac).
+ Defined.
+
+ Instance Types_cancell_iso a : Isomorphic(C:=TypesL) ([],,a) a :=
+ { iso_forward := snd_initial _ ;; cnd_ant_llecnac _ a
+ ; iso_backward := snd_initial _ ;; cnd_ant_cancell _ a
+ }.
+ abstract (simpl; eapply cndr_inert; unfold identityProof; [ apply PL | idtac | idtac ]; ndpc_tac).
+ abstract (simpl; eapply cndr_inert; unfold identityProof; [ apply PL | idtac | idtac ]; ndpc_tac).
+ Defined.
+
+ Lemma coincide' : nd_llecnac === nd_rlecnac.
+ set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
+ set (isos_forward_equal_then_backward_equal _ _ q') as qq.
+ apply qq.
+ Qed.
+
+ Lemma Types_assoc_lemma : ∀a b X Y : TypesL,
+ ∀f : X ~~{ TypesL }~~> Y,
+ #(Types_assoc_iso a X b) >>> (Types_first b >>>> Types_second a) \ f ~~
+ (Types_second a >>>> Types_first b) \ f >>> #(Types_assoc_iso a Y b).
+ intros.
+ Opaque nd_id.
+ simpl.
+ Transparent nd_id.
+ unfold ehom.
+
+ nd_swap_ltac p PL.
+ setoid_rewrite p.
+ clear p.
+
+ repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+
+ setoid_rewrite (@nd_prod_split_left _ Rule PL _ _ _ []).
+ setoid_rewrite (@nd_prod_split_left _ Rule PL _ _ _ []).
+ setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
+ setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
+
+ setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).
+
+ set (ni_commutes' (jud_mon_cancelr PL) f) as q.
+ simpl in q.
+ setoid_rewrite <- q.
+ clear q.
+
+ set (ni_commutes' (jud_mon_cancell PL) f) as q.
+ simpl in q.
+ setoid_rewrite coincide' in q.
+ setoid_rewrite <- q.
+ clear q.
+
+ setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ apply ndr_comp_respects; try reflexivity.
+
+ apply (cndr_inert pl_cnd); auto; ndpc_tac; auto.
+ Qed.
+
+ Instance Types_assoc a b : Types_second a >>>> Types_first b <~~~> Types_first b >>>> Types_second a :=
+ { ni_iso := fun c => Types_assoc_iso a c b }.
+ apply Types_assoc_lemma.
+ Defined.
+
+ Lemma Types_assoc_ll_lemma :
+ ∀a b X Y : TypesL,
+ ∀f : X ~~{ TypesL }~~> Y,
+ #(Types_assoc_iso a b X) >>> (Types_second b >>>> Types_second a) \ f ~~
+ Types_second (a,, b) \ f >>> #(Types_assoc_iso a b Y).
+
+ intros.
+ Opaque nd_id.
+ simpl.
+ Transparent nd_id.
+ unfold ehom.
+ nd_swap_ltac p PL.
+ setoid_rewrite p.
+ clear p.
+
+ setoid_rewrite (@nd_prod_split_left _ Rule PL _ _ _ []).
+ setoid_rewrite (@nd_prod_split_left _ Rule PL _ _ _ []).
+ setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
+
+ repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).
+
+ set (ni_commutes' (jud_mon_cancelr PL) f) as q.
+ Opaque nd_id.
+ simpl in q.
+ setoid_rewrite <- q.
+
+ clear q.
+ set (ni_commutes' (jud_mon_cancell PL) f) as q.
+ simpl in q.
+ set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
+ set (isos_forward_equal_then_backward_equal _ _ q') as qq.
+ simpl in qq.
+ setoid_rewrite qq in q.
+ clear q' qq.
+ setoid_rewrite <- q.
+
+ setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ apply ndr_comp_respects; try reflexivity.
+
+ Transparent nd_id.
+ apply (cndr_inert pl_cnd); auto; ndpc_tac.
+ Qed.
+
+ Instance Types_assoc_ll a b : Types_second (a,,b) <~~~> Types_second b >>>> Types_second a :=
+ { ni_iso := fun c => Types_assoc_iso a b c }.
+ apply Types_assoc_ll_lemma.
+ Defined.
+
+ Lemma Types_assoc_rr_lemma :
+ ∀a b A B : TypesL,
+ ∀f : A ~~{ TypesL }~~> B,
+ #(Types_assoc_iso A a b) ⁻¹ >>> (Types_first a >>>> Types_first b) \ f ~~
+ Types_first (a,, b) \ f >>> #(Types_assoc_iso B a b) ⁻¹.
+ intros.
+ Opaque nd_id.
+ simpl.
+ Transparent nd_id.
+
+ rename A into X.
+ rename B into Y.
+ unfold ehom.
+ nd_swap_ltac p PL.
+ setoid_rewrite p.
+ clear p.
+
+ setoid_rewrite (@nd_prod_split_left _ Rule PL _ _ _ []).
+ setoid_rewrite (@nd_prod_split_left _ Rule PL _ _ _ []).
+ setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
+
+ repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).
+
+ set (ni_commutes' (jud_mon_cancelr PL) f) as q.
+ Opaque nd_id.
+ simpl in q.
+ setoid_rewrite <- q.
+
+ clear q.
+ set (ni_commutes' (jud_mon_cancell PL) f) as q.
+ simpl in q.
+ set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
+ set (isos_forward_equal_then_backward_equal _ _ q') as qq.
+ simpl in qq.
+ setoid_rewrite qq in q.
+ clear q' qq.
+ setoid_rewrite <- q.
+
+ setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ apply ndr_comp_respects; try reflexivity.
+
+ Transparent nd_id.
+ apply (cndr_inert pl_cnd); auto; ndpc_tac.
+ Qed.
+
+ Instance Types_assoc_rr a b : Types_first (a,,b) <~~~> Types_first a >>>> Types_first b :=
+ { ni_iso := fun c => iso_inv _ _ (Types_assoc_iso c a b) }.
+ apply Types_assoc_rr_lemma.
+ Defined.
+
+ Lemma Types_cancelr_lemma :
+ ∀A B : TypesL,
+ ∀f : A ~~{ TypesL }~~> B,
+ #(Types_cancelr_iso A) >>> functor_id TypesL \ f ~~
+ Types_first [] \ f >>> #(Types_cancelr_iso B).
+ intros.
+ Opaque nd_id.
+ simpl.
+ unfold ehom.
+ nd_swap_ltac p PL.
+ setoid_rewrite p.
+ setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
+ repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).
+
+ set (ni_commutes' (jud_mon_cancelr PL) f) as q.
+ Opaque nd_id.
+ simpl in q.
+ setoid_rewrite <- q.
+ clear q.
+
+ set (ni_commutes' (jud_mon_cancell PL) f) as q.
+ simpl in q.
+ set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
+ set (isos_forward_equal_then_backward_equal _ _ q') as qq.
+ simpl in qq.
+ setoid_rewrite qq in q.
+ clear q' qq.
+ setoid_rewrite <- q.
+
+ setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ apply ndr_comp_respects; try reflexivity.
+ Transparent nd_id.
+ simpl.
+ apply (cndr_inert pl_cnd); auto; ndpc_tac.
+ Qed.
+
+ Instance Types_cancelr : Types_first [] <~~~> functor_id _ :=
+ { ni_iso := Types_cancelr_iso }.
+ apply Types_cancelr_lemma.
+ Defined.
+
+ Lemma Types_cancell_lemma :
+ ∀A B : TypesL,
+ ∀f : A ~~{ TypesL }~~> B,
+ #(Types_cancell_iso A) >>> functor_id TypesL \ f ~~
+ Types_second [] \ f >>> #(Types_cancell_iso B).
+ intros.
+ Opaque nd_id.
+ simpl.
+ unfold ehom.
+ nd_swap_ltac p PL.
+ setoid_rewrite p.
+ setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
+ repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).
+
+ set (ni_commutes' (jud_mon_cancelr PL) f) as q.
+ Opaque nd_id.
+ simpl in q.
+ setoid_rewrite <- q.
+ clear q.
+
+ set (ni_commutes' (jud_mon_cancell PL) f) as q.
+ simpl in q.
+ set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
+ set (isos_forward_equal_then_backward_equal _ _ q') as qq.
+ simpl in qq.
+ setoid_rewrite qq in q.
+ clear q' qq.
+ setoid_rewrite <- q.
+ setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+
+ apply ndr_comp_respects; try reflexivity.
+ Transparent nd_id.
+ simpl.
+ apply (cndr_inert pl_cnd); auto; ndpc_tac.
+ Qed.
+
+ Instance Types_cancell : Types_second [] <~~~> functor_id _ :=
+ { ni_iso := Types_cancell_iso }.
+ apply Types_cancell_lemma.
+ Defined.
+
+ Lemma TypesL_assoc_central a b c : CentralMorphism(H:=Types_binoidal) #((Types_assoc a b) c).
+ intros.
+ apply Build_CentralMorphism.
+ intros.
+ unfold bin_obj.
+ unfold ebc_bobj.
+ Opaque nd_id.
+ simpl.
+ unfold ehom.
+ nd_swap_ltac p PL.
+ setoid_rewrite p.
+ clear p.
+ setoid_rewrite (@nd_prod_split_left _ Rule PL _ _ _ []).
+ setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
+ repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).
+
+ set (ni_commutes' (jud_mon_cancelr PL) g) as q.
+ Opaque nd_id.
+ simpl in q.
+ setoid_rewrite <- q.
+ clear q.
+
+ set (ni_commutes' (jud_mon_cancell PL) g) as q.
+ simpl in q.
+ set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
+ set (isos_forward_equal_then_backward_equal _ _ q') as qq.
+ simpl in qq.
+ setoid_rewrite qq in q.
+ clear q' qq.
+ setoid_rewrite <- q.
+
+ setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ apply ndr_comp_respects.
+ reflexivity.
+
+ Transparent nd_id.
+ apply (cndr_inert pl_cnd); auto; ndpc_tac.
+
+ Opaque nd_id.
+ intros.
+ unfold bin_obj.
+ unfold ebc_bobj.
+ simpl.
+ unfold ehom.
+ symmetry.
+ nd_swap_ltac p PL.
+ setoid_rewrite p.
+ clear p.
+ setoid_rewrite (@nd_prod_split_left _ Rule PL _ _ _ []).
+ setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
+ repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).
+
+ set (ni_commutes' (jud_mon_cancelr PL) g) as q.
+ Opaque nd_id.
+ simpl in q.
+ setoid_rewrite <- q.
+ clear q.
+
+ set (ni_commutes' (jud_mon_cancell PL) g) as q.
+ simpl in q.
+ set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
+ set (isos_forward_equal_then_backward_equal _ _ q') as qq.
+ simpl in qq.
+ setoid_rewrite qq in q.
+ clear q' qq.
+ setoid_rewrite <- q.
+
+ setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ apply ndr_comp_respects.
+ reflexivity.
+
+ Transparent nd_id.
+ apply (cndr_inert pl_cnd); auto; ndpc_tac.
+ Qed.
+
+ Lemma TypesL_cancell_central a : CentralMorphism(H:=Types_binoidal) #(Types_cancell a).
+ intros.
+ apply Build_CentralMorphism.
+ Opaque nd_id.
+ intros.
+ unfold bin_obj.
+ unfold ebc_bobj.
+ simpl.
+ unfold ehom.
+ nd_swap_ltac p PL.
+ setoid_rewrite p.
+ clear p.
+ setoid_rewrite (@nd_prod_split_left _ Rule PL _ _ _ []).
+ setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
+ repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).
+
+ set (ni_commutes' (jud_mon_cancelr PL) g) as q.
+ Opaque nd_id.
+ simpl in q.
+ setoid_rewrite <- q.
+ clear q.
+
+ set (ni_commutes' (jud_mon_cancell PL) g) as q.
+ simpl in q.
+ set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
+ set (isos_forward_equal_then_backward_equal _ _ q') as qq.
+ simpl in qq.
+ setoid_rewrite qq in q.
+ clear q' qq.
+ setoid_rewrite <- q.
+
+ setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ apply ndr_comp_respects.
+ reflexivity.
+
+ Transparent nd_id.
+ apply (cndr_inert pl_cnd); auto; ndpc_tac.
+
+ Opaque nd_id.
+ intros.
+ unfold bin_obj.
+ unfold ebc_bobj.
+ simpl.
+ unfold ehom.
+ symmetry.
+ nd_swap_ltac p PL.
+ setoid_rewrite p.
+ clear p.
+ setoid_rewrite (@nd_prod_split_left _ Rule PL _ _ _ []).
+ setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
+ repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).
+
+ set (ni_commutes' (jud_mon_cancelr PL) g) as q.
+ Opaque nd_id.
+ simpl in q.
+ setoid_rewrite <- q.
+ clear q.
+
+ set (ni_commutes' (jud_mon_cancell PL) g) as q.
+ simpl in q.
+ set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
+ set (isos_forward_equal_then_backward_equal _ _ q') as qq.
+ simpl in qq.
+ setoid_rewrite qq in q.
+ clear q' qq.
+ setoid_rewrite <- q.
+
+ setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ apply ndr_comp_respects.
+ reflexivity.
+
+ Transparent nd_id.
+ apply (cndr_inert pl_cnd); auto; ndpc_tac.
+ Qed.
+
+ Lemma TypesL_cancelr_central a : CentralMorphism(H:=Types_binoidal) #(Types_cancelr a).
+ intros.
+ apply Build_CentralMorphism.
+ Opaque nd_id.
+ intros.
+ unfold bin_obj.
+ unfold ebc_bobj.
+ simpl.
+ unfold ehom.
+ nd_swap_ltac p PL.
+ setoid_rewrite p.
+ clear p.
+ setoid_rewrite (@nd_prod_split_left _ Rule PL _ _ _ []).
+ setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
+ repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).
+
+ set (ni_commutes' (jud_mon_cancelr PL) g) as q.
+ Opaque nd_id.
+ simpl in q.
+ setoid_rewrite <- q.
+ clear q.
+
+ set (ni_commutes' (jud_mon_cancell PL) g) as q.
+ simpl in q.
+ set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
+ set (isos_forward_equal_then_backward_equal _ _ q') as qq.
+ simpl in qq.
+ setoid_rewrite qq in q.
+ clear q' qq.
+ setoid_rewrite <- q.
+
+ setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ apply ndr_comp_respects.
+ reflexivity.
+
+ Transparent nd_id.
+ apply (cndr_inert pl_cnd); auto; ndpc_tac.
+
+ Opaque nd_id.
+ intros.
+ unfold bin_obj.
+ unfold ebc_bobj.
+ simpl.
+ unfold ehom.
+ symmetry.
+ nd_swap_ltac p PL.
+ setoid_rewrite p.
+ clear p.
+ setoid_rewrite (@nd_prod_split_left _ Rule PL _ _ _ []).
+ setoid_rewrite (@nd_prod_split_right _ Rule PL _ _ _ []).
+ repeat setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ setoid_rewrite <- (@ndr_comp_associativity _ Rule PL).
+
+ set (ni_commutes' (jud_mon_cancelr PL) g) as q.
+ Opaque nd_id.
+ simpl in q.
+ setoid_rewrite <- q.
+ clear q.
+
+ set (ni_commutes' (jud_mon_cancell PL) g) as q.
+ simpl in q.
+ set (coincide (pmon_triangle(PreMonoidalCat:=(Judgments_Category_premonoidal PL)))) as q'.
+ set (isos_forward_equal_then_backward_equal _ _ q') as qq.
+ simpl in qq.
+ setoid_rewrite qq in q.
+ clear q' qq.
+ setoid_rewrite <- q.
+
+ setoid_rewrite (@ndr_comp_associativity _ Rule PL).
+ apply ndr_comp_respects.
+ reflexivity.
+
+ Transparent nd_id.
+ apply (cndr_inert pl_cnd); auto; ndpc_tac.
+ Qed.
+
+ Instance TypesL_PreMonoidal : PreMonoidalCat Types_binoidal [] :=
+ { pmon_assoc := Types_assoc
+ ; pmon_cancell := Types_cancell
+ ; pmon_cancelr := Types_cancelr
+ ; pmon_assoc_rr := Types_assoc_rr
+ ; pmon_assoc_ll := Types_assoc_ll
+ }.
+ abstract (apply Build_Pentagon; intros; simpl; eapply cndr_inert; try apply PL; ndpc_tac).
+ abstract (apply Build_Triangle; intros; simpl; eapply cndr_inert; try apply PL; ndpc_tac).
+ intros; simpl; reflexivity.
+ intros; simpl; reflexivity.
+ apply TypesL_assoc_central.
+ apply TypesL_cancelr_central.
+ apply TypesL_cancell_central.
+ Defined.
+
+End ProgrammingLanguageCategory.
+
--- /dev/null
+(*********************************************************************************************************************************)
+(* ProgrammingLanguageEnrichment *)
+(* *)
+(* Types are enriched in Judgments. *)
+(* *)
+(*********************************************************************************************************************************)
+
+Generalizable All Variables.
+Require Import Preamble.
+Require Import General.
+Require Import Categories_ch1_3.
+Require Import InitialTerminal_ch2_2.
+Require Import Functors_ch1_4.
+Require Import Isomorphisms_ch1_5.
+Require Import ProductCategories_ch1_6_1.
+Require Import OppositeCategories_ch1_6_2.
+Require Import Enrichment_ch2_8.
+Require Import Subcategories_ch7_1.
+Require Import NaturalTransformations_ch7_4.
+Require Import NaturalIsomorphisms_ch7_5.
+Require Import BinoidalCategories.
+Require Import PreMonoidalCategories.
+Require Import MonoidalCategories_ch7_8.
+Require Import Coherence_ch7_8.
+Require Import Enrichment_ch2_8.
+Require Import RepresentableStructure_ch7_2.
+Require Import FunctorCategories_ch7_7.
+
+Require Import Enrichments.
+Require Import NaturalDeduction.
+Require Import NaturalDeductionCategory.
+Require Import ProgrammingLanguageCategory.
+ Export ProgrammingLanguageCategory.
+
+Section ProgrammingLanguageEnrichment.
+
+ Context `(PL:ProgrammingLanguage).
+
+ Definition TypesEnrichedInJudgments : SurjectiveEnrichment.
+ refine
+ {| senr_c_pm := TypesL_PreMonoidal PL
+ ; senr_v := JudgmentsL PL
+ ; senr_v_bin := Judgments_Category_binoidal _
+ ; senr_v_pmon := Judgments_Category_premonoidal _
+ ; senr_v_mon := Judgments_Category_monoidal _
+ ; senr_c_bin := Types_binoidal PL
+ ; senr_c := TypesL PL
+ |}.
+ Defined.
+
+End ProgrammingLanguageEnrichment.
+
Require Import NaturalDeduction.
Require Import NaturalDeductionCategory.
Require Import GeneralizedArrow.
-Require Import ProgrammingLanguage.
+Require Import ProgrammingLanguageEnrichment.
Require Import ProgrammingLanguageReification.
Require Import SectionRetract_ch2_4.
Require Import GeneralizedArrowFromReification.
Require Import Enrichments.
Require Import Reification.
Require Import GeneralizedArrow.
-Require Import ProgrammingLanguage.
+Require Import ProgrammingLanguageEnrichment.
Section ProgrammingLanguageGeneralizedArrow.
Require Import NaturalDeduction.
Require Import NaturalDeductionCategory.
Require Import ProgrammingLanguage.
+Require Import ProgrammingLanguageCategory.
Require Import Enrichments.
Section ProgrammingLanguageReification.
-Subproject commit 0ecd73c172f67634fa956fb52b332e6effb5a04d
+Subproject commit 422dab8d300548c294b95c0f4bbf27aecadbd745
projects / coq-hetmet.git / commitdiff