From: Adam Megacz Date: Sun, 11 May 2014 00:47:11 +0000 (-0700) Subject: merge proof correction X-Git-Url: http://git.megacz.com/?p=coq-hetmet.git;a=commitdiff_plain;h=HEAD;hp=4baa0f46d10b878eb524c25e129d5e8f026ba53a merge proof correction --- diff --git a/.gitignore b/.gitignore index aa0d01f..e420df5 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,8 @@ examples/tutorial.tex examples/tutorial.pdf build/ build/** +examples/.build +examples/*.o +examples/*.hi + + diff --git a/Makefile b/Makefile index c77a3dd..c372b85 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,8 @@ 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 @@ -9,11 +11,24 @@ all: $(allfiles) 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 @@ -29,10 +44,23 @@ src/categories/src: 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 diff --git a/examples/BiGArrow.hs b/examples/BiGArrow.hs index 466fbc2..a6ecde4 100644 --- a/examples/BiGArrow.hs +++ b/examples/BiGArrow.hs @@ -1,7 +1,7 @@ -{-# 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, (.) ) diff --git a/examples/BitSerialHardware.hs b/examples/BitSerialHardware.hs new file mode 100644 index 0000000..0a35247 --- /dev/null +++ b/examples/BitSerialHardware.hs @@ -0,0 +1,70 @@ +{-# 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 diff --git a/examples/BitSerialHardware.hs- b/examples/BitSerialHardware.hs- new file mode 100644 index 0000000..0a35247 --- /dev/null +++ b/examples/BitSerialHardware.hs- @@ -0,0 +1,70 @@ +{-# 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 diff --git a/examples/CircuitExample.hs b/examples/CircuitExample.hs index f4f5151..f32d5ff 100644 --- a/examples/CircuitExample.hs +++ b/examples/CircuitExample.hs @@ -1,8 +1,8 @@ {-# 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, (.) ) diff --git a/examples/Demo.hs b/examples/Demo.hs new file mode 100644 index 0000000..fb8666f --- /dev/null +++ b/examples/Demo.hs @@ -0,0 +1,179 @@ +{-# 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 diff --git a/examples/DemoMain.hs b/examples/DemoMain.hs new file mode 100644 index 0000000..0da3644 --- /dev/null +++ b/examples/DemoMain.hs @@ -0,0 +1,62 @@ +{-# 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) diff --git a/examples/DotProduct.hs b/examples/DotProduct.hs index 6de0c01..4b36019 100644 --- a/examples/DotProduct.hs +++ b/examples/DotProduct.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -XModalTypes -ddump-types -XNoMonoPatBinds -XFlexibleContexts #-} module DotProduct where -import GHC.HetMet.CodeTypes hiding ((-)) +import GHC.HetMet.GuestLanguage hiding ((-)) import Prelude hiding ( id, (.) ) -------------------------------------------------------------------------------- diff --git a/examples/Fail.hs b/examples/Fail.hs new file mode 100644 index 0000000..06466bc --- /dev/null +++ b/examples/Fail.hs @@ -0,0 +1,2 @@ +applyCircuit = + <[ \higherOrderCircuit -> \arg -> higherOrderCircuit arg ]> diff --git a/examples/GArrowAssTypes.hs b/examples/GArrowAssTypes.hs new file mode 100644 index 0000000..45d6204 --- /dev/null +++ b/examples/GArrowAssTypes.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE RankNTypes, FlexibleContexts, NoMonomorphismRestriction, ScopedTypeVariables #-} +-- +-- | +-- Module : GArrowAssTypes +-- Copyright : none +-- License : public domain +-- +-- Maintainer : Adam Megacz +-- 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 + + + diff --git a/examples/GArrowDemo.hs b/examples/GArrowDemo.hs new file mode 100644 index 0000000..e341bf2 --- /dev/null +++ b/examples/GArrowDemo.hs @@ -0,0 +1,17 @@ + + +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 + diff --git a/examples/GArrowInclusion.hs b/examples/GArrowInclusion.hs new file mode 100644 index 0000000..e8c7fb6 --- /dev/null +++ b/examples/GArrowInclusion.hs @@ -0,0 +1,6 @@ +{-# 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 diff --git a/examples/GArrowPortShape.hs b/examples/GArrowPortShape.hs new file mode 100644 index 0000000..5b4f5b6 --- /dev/null +++ b/examples/GArrowPortShape.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleContexts, FlexibleInstances, TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : GArrowPortShape +-- Copyright : none +-- License : public domain +-- +-- Maintainer : Adam Megacz +-- 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 + diff --git a/examples/GArrowPretty.hs b/examples/GArrowPretty.hs new file mode 100644 index 0000000..0be25dc --- /dev/null +++ b/examples/GArrowPretty.hs @@ -0,0 +1,41 @@ +{-# 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 + diff --git a/examples/GArrowShow.hs b/examples/GArrowShow.hs new file mode 100644 index 0000000..39695d6 --- /dev/null +++ b/examples/GArrowShow.hs @@ -0,0 +1,6 @@ +{-# 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 diff --git a/examples/GArrowSkeleton.hs b/examples/GArrowSkeleton.hs new file mode 100644 index 0000000..a71486f --- /dev/null +++ b/examples/GArrowSkeleton.hs @@ -0,0 +1,513 @@ +{-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleContexts, FlexibleInstances, TypeFamilies, RankNTypes #-} +----------------------------------------------------------------------------- +-- | +-- Module : GArrowSkeleton +-- Copyright : none +-- License : public domain +-- +-- Maintainer : Adam Megacz +-- 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 diff --git a/examples/GArrowTikZ.hs b/examples/GArrowTikZ.hs index 1f62969..1b15fab 100644 --- a/examples/GArrowTikZ.hs +++ b/examples/GArrowTikZ.hs @@ -1,36 +1,600 @@ -{-# 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 +-- 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 diff --git a/examples/GArrowTutorial.hs b/examples/GArrowTutorial.hs index c614d0d..be7c930 100644 --- a/examples/GArrowTutorial.hs +++ b/examples/GArrowTutorial.hs @@ -3,8 +3,8 @@ module GArrowTutorial 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, (.) ) diff --git a/examples/GArrowVerilog.hs b/examples/GArrowVerilog.hs index c867dac..e3bd441 100644 --- a/examples/GArrowVerilog.hs +++ b/examples/GArrowVerilog.hs @@ -1,65 +1,196 @@ -{-# 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)) diff --git a/examples/IFLDemos.hs b/examples/IFLDemos.hs new file mode 100644 index 0000000..288e6a4 --- /dev/null +++ b/examples/IFLDemos.hs @@ -0,0 +1,96 @@ +{-# 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 + ]> diff --git a/examples/Makefile b/examples/Makefile new file mode 100644 index 0000000..4e47c6e --- /dev/null +++ b/examples/Makefile @@ -0,0 +1,49 @@ +# -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 diff --git a/examples/Stack.hs b/examples/Stack.hs new file mode 100644 index 0000000..19272c2 --- /dev/null +++ b/examples/Stack.hs @@ -0,0 +1,244 @@ +{-# 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 diff --git a/examples/TuringMachine.hs b/examples/TuringMachine.hs new file mode 100644 index 0000000..df3ac31 --- /dev/null +++ b/examples/TuringMachine.hs @@ -0,0 +1,81 @@ +{-# 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 diff --git a/examples/Unflattening.hs b/examples/Unflattening.hs index f9ca4ba..6dfbf78 100644 --- a/examples/Unflattening.hs +++ b/examples/Unflattening.hs @@ -2,7 +2,7 @@ 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, (.) ) diff --git a/examples/Unify.hs b/examples/Unify.hs new file mode 100644 index 0000000..34761ea --- /dev/null +++ b/examples/Unify.hs @@ -0,0 +1,98 @@ +-- | 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 diff --git a/examples/VerilogDemo.hs b/examples/VerilogDemo.hs new file mode 100644 index 0000000..9c0b4fd --- /dev/null +++ b/examples/VerilogDemo.hs @@ -0,0 +1,9 @@ +{-# 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 ]> diff --git a/examples/tex-bits/prauctex.def b/examples/tex-bits/prauctex.def new file mode 100644 index 0000000..4f8f7fa --- /dev/null +++ b/examples/tex-bits/prauctex.def @@ -0,0 +1,61 @@ +%% +%% 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 . +\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'. diff --git a/examples/tex-bits/prcounters.def b/examples/tex-bits/prcounters.def new file mode 100644 index 0000000..f7b5726 --- /dev/null +++ b/examples/tex-bits/prcounters.def @@ -0,0 +1,38 @@ +%% +%% 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 . +\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'. diff --git a/examples/tex-bits/preview.drv b/examples/tex-bits/preview.drv new file mode 100644 index 0000000..76ec429 --- /dev/null +++ b/examples/tex-bits/preview.drv @@ -0,0 +1,34 @@ +%% +%% 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 . + \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'. diff --git a/examples/tex-bits/preview.dtx b/examples/tex-bits/preview.dtx new file mode 100644 index 0000000..fd834c6 --- /dev/null +++ b/examples/tex-bits/preview.dtx @@ -0,0 +1,1872 @@ +% \iffalse +%% The preview style for extracting previews from LaTeX documents. +%% Developed as part of 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 +% || 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 +% +% \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 +% +% \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@@} +% +% \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} +% +% \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 +% +% \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} +% +% \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}} +% +% \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} +% +% \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 +% +% \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} +% +% +% \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} +%\ifPreview\else\expandafter\endinput\fi +%\nofiles +%\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} +%\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)}} +% \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} +%\hbadness=\maxdimen +%\newcount\hbadness +%\vbadness=\maxdimen +%\let\vbadness=\hbadness +%\hfuzz=\maxdimen +%\newdimen\hfuzz +%\vfuzz=\maxdimen +%\let\vfuzz=\hfuzz +%\showboxdepth=-1 +%\showboxbreadth=-1 +% \end{macrocode} +% Ok, now we load a possible configuration file. +% \begin{macrocode} +%\pr@loadcfg{prauctex} +% \end{macrocode} +% And here we cater for several frequently used commands in +% |prauctex.cfg|: +% \begin{macrocode} +%\PreviewMacro*[[][#1{}]\footnote +%\PreviewMacro*[?[{@{[]}}{}][#1]\item +%\PreviewMacro*\emph +%\PreviewMacro*\textrm +%\PreviewMacro*\textit +%\PreviewMacro*\textsc +%\PreviewMacro*\textsf +%\PreviewMacro*\textsl +%\PreviewMacro*\texttt +%\PreviewMacro*\textcolor +%\PreviewMacro*\mbox +%\PreviewMacro*[][#1{}]\author +%\PreviewMacro*[][#1{}]\title +%\PreviewMacro*\and +%\PreviewMacro*\thanks +%\PreviewMacro*[][#1{}]\caption +%\preview@delay{\@ifundefined{pr@\string\@startsection}{% +% \PreviewMacro*[!!!!!!*][#1{}]\@startsection}{}} +%\preview@delay{\@ifundefined{pr@\string\chapter}{% +% \PreviewMacro*[*][#1{}]\chapter}{}} +%\PreviewMacro*\index +% \end{macrocode} +% +% \subsection{The \texttt{lyx} option} +% The following is the option providing LyX with info for its preview +% implementation. +% \begin{macrocode} +%\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}} +% \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} +%\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.} +% \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} +%\ifPreview\else\expandafter\endinput\fi +%\AtEndOfPackage{% +% \showboxbreadth\maxdimen +% \showboxdepth\maxdimen} +%\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} +%\ifPreview\else\expandafter\endinput\fi +%\pr@addto@front\pr@ship@start{\let\tracingonline\count@ +% \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} +%\ifx\PreviewBorder\@undefined +% \newdimen\PreviewBorder +% \PreviewBorder=0.50001bp +%\fi +%\ifx\PreviewBbAdjust\@undefined +% \def\PreviewBbAdjust{-\PreviewBorder -\PreviewBorder +% \PreviewBorder \PreviewBorder} +%\fi +% \end{macrocode} +% \end{macro} +% \end{macro} +% Here is stuff used for parsing this: +% \begin{macrocode} +%\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} +% \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} +%\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 +% \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} +%\ifnum\pr@graphicstype=\@ne +%\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} +% \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 +% < /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} +% \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} +% \special{!userdict begin/bop-hook{% +% preview-bop-level 0 le{% +% 7{currentfile token not{stop}if +% 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} +% 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} +% 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 +% \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} +% 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} +% < /PageOffset[7 -2 roll [1 1 dtransform exch]% +% {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} +% //bop-hook exec}bind def end}}} +%\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} +%\ifPreview\else\expandafter\endinput\fi +%\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} +%\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} +% \ifpr@setbox\z@{#1}% +% \global\setbox\pr@labelbox\vbox{\unvbox\pr@labelbox +% \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} +%\def\ifpr@setbox#1#2{% +% \romannumeral% +% \ifx\protect\@typeset@protect\ifpr@outer\else +% \end{macrocode} +% Ignore empty labels\dots +% \begin{macrocode} +% \z@\bgroup +% \protected@edef\next{#2}\@onelevel@sanitize\next +% \ifx\next\@empty\egroup\romannumeral\else +% \end{macrocode} +% and labels equal to the last one. +% \begin{macrocode} +% \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} +% \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} +%\def\pr@boxlabel#1{\hbox{\normalfont +% \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} +%\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}% +% \end{macrocode} +% Set the width of the box to empty so that the label placement gets +% not disturbed, then append it. +% \begin{macrocode} +% \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} +%\g@addto@macro\pr@ship@start{% +% \global\setbox\pr@labelbox\box\voidb@x +% \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} +% \global\let\pr@@label\label \let\label\pr@label +% \global\let\pr@@maketag\maketag@@@ +% \let\maketag@@@\pr@maketag +%} +% \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} +%\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} +% \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} +%\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} +% \input docstrip +% \askforoverwritefalse +% \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 +% \end{macrocode} +% And here comes the documentation driver. +% \begin{macrocode} +% \documentclass{ltxdoc} +% \usepackage{preview} +% \let\ifPreview\relax +% \newcommand\previewlatex{\texttt{preview-latex}} +% \begin{document} +% \DocInput{preview.dtx} +% \end{document} +% \end{macrocode} +% \Finale{} +% \iffalse +% Local Variables: +% mode: doctex +% TeX-master: "preview.drv" +% End: +% \fi diff --git a/examples/tex-bits/preview.ins b/examples/tex-bits/preview.ins new file mode 100644 index 0000000..1d4229d --- /dev/null +++ b/examples/tex-bits/preview.ins @@ -0,0 +1,44 @@ +%% +%% 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 . + \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'. diff --git a/examples/tex-bits/preview.sty b/examples/tex-bits/preview.sty new file mode 100644 index 0000000..3040298 --- /dev/null +++ b/examples/tex-bits/preview.sty @@ -0,0 +1,391 @@ +%% +%% 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 . +\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 . +\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'. diff --git a/examples/tex-bits/prfootnotes.def b/examples/tex-bits/prfootnotes.def new file mode 100644 index 0000000..2d525a8 --- /dev/null +++ b/examples/tex-bits/prfootnotes.def @@ -0,0 +1,28 @@ +%% +%% 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 . +\PreviewMacro[[!]\footnote %] +\endinput +%% +%% End of file `prfootnotes.def'. diff --git a/examples/tex-bits/prlyx.def b/examples/tex-bits/prlyx.def new file mode 100644 index 0000000..fd1dab7 --- /dev/null +++ b/examples/tex-bits/prlyx.def @@ -0,0 +1,32 @@ +%% +%% 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 . +\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'. diff --git a/examples/tex-bits/prshowbox.def b/examples/tex-bits/prshowbox.def new file mode 100644 index 0000000..3280b29 --- /dev/null +++ b/examples/tex-bits/prshowbox.def @@ -0,0 +1,32 @@ +%% +%% 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 . +\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'. diff --git a/examples/tex-bits/prshowlabels.def b/examples/tex-bits/prshowlabels.def new file mode 100644 index 0000000..d0d6108 --- /dev/null +++ b/examples/tex-bits/prshowlabels.def @@ -0,0 +1,67 @@ +%% +%% 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 . +\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'. diff --git a/examples/tex-bits/prtightpage.def b/examples/tex-bits/prtightpage.def new file mode 100644 index 0000000..31516be --- /dev/null +++ b/examples/tex-bits/prtightpage.def @@ -0,0 +1,146 @@ +%% +%% 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 . +\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 + <>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 + <>setpagedevice}if% + //bop-hook exec}bind def end}}} +\fi +\endinput +%% +%% End of file `prtightpage.def'. diff --git a/examples/tex-bits/prtracingall.def b/examples/tex-bits/prtracingall.def new file mode 100644 index 0000000..7dfc7e3 --- /dev/null +++ b/examples/tex-bits/prtracingall.def @@ -0,0 +1,30 @@ +%% +%% 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 . +\ifPreview\else\expandafter\endinput\fi +\pr@addto@front\pr@ship@start{\let\tracingonline\count@ + \let\errorstopmode\@empty\tracingall} +\endinput +%% +%% End of file `prtracingall.def'. diff --git a/src/All.v b/src/All.v index d4956dd..9443bbb 100644 --- a/src/All.v +++ b/src/All.v @@ -1,4 +1,7 @@ Require Import ExtractionMain. +Require Import HaskProgrammingLanguage. +Require Import PCF. +Require Import HaskFlattener. Require Import ProgrammingLanguageArrow. Require Import ProgrammingLanguageReification. Require Import ProgrammingLanguageFlattening. diff --git a/src/Extraction-prefix.hs b/src/Extraction-prefix.hs index fbe22cb..bbd2b81 100644 --- a/src/Extraction-prefix.hs +++ b/src/Extraction-prefix.hs @@ -1,6 +1,8 @@ +{-# 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 @@ -13,10 +15,14 @@ import qualified Literal 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 @@ -28,11 +34,11 @@ import qualified Data.List 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] @@ -51,16 +57,17 @@ cmpAlts (a1,_,_) (a2,_,_) = Data.Ord.compare a2 a1 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 = @@ -68,7 +75,9 @@ 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 @@ -85,20 +94,21 @@ sanitizeForLatex ('#':x) = "\\#"++(sanitizeForLatex x) 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. @@ -108,12 +118,11 @@ coreKindToKind k = -- 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 = @@ -130,72 +139,18 @@ 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 diff --git a/src/ExtractionMain.v b/src/ExtractionMain.v index 2f46f85..42a29ed 100644 --- a/src/ExtractionMain.v +++ b/src/ExtractionMain.v @@ -13,9 +13,11 @@ Require Import Preamble. 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. @@ -33,8 +35,7 @@ Require Import HaskStrongToWeak. Require Import HaskWeakToCore. Require Import HaskProofToStrong. -Require Import HaskProofFlattener. -Require Import HaskProofStratified. +Require Import HaskFlattener. Open Scope string_scope. Extraction Language Haskell. @@ -70,10 +71,22 @@ Variable mkSystemName : Unique -> string -> nat -> Name. 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). @@ -91,23 +104,22 @@ Section core2proof. (* 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+++ @@ -134,7 +146,7 @@ Section core2proof. 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) )))))))). @@ -163,13 +175,15 @@ Section core2proof. 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 @@ -223,10 +237,231 @@ Section core2proof. 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 => @@ -236,45 +471,144 @@ Section core2proof. ((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. diff --git a/src/General.v b/src/General.v index d017894..541dc6f 100644 --- a/src/General.v +++ b/src/General.v @@ -20,6 +20,24 @@ Class EqDecidable (T:Type) := }. 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 }. @@ -88,6 +106,18 @@ Fixpoint treeReduce {T:Type}{R:Type}(mapLeaf:T->R)(mergeBranches:R->R->R) (t:Tre 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), @@ -188,6 +218,104 @@ Fixpoint mapProp {A:Type} (f:A->Prop) (l:list A) : Prop := | (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. @@ -444,6 +572,112 @@ Instance EqDecidableList {T:Type}(eqd:EqDecidable T) : EqDecidable (list T). 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 *) @@ -667,6 +901,30 @@ Lemma ilist_chop' {T}{F}{l1 l2:list T}(v:IList T F (app l1 l2)) : IList T F l2. 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 @@ -739,6 +997,10 @@ Lemma extensionality_composes : forall t1 t2 t3 (f f':t1->t2) (g g':t2->t3), 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. @@ -775,7 +1037,7 @@ Definition orErrorBindWithMessage {T:Type} (oe:OrError T) {Q:Type} (f:T -> OrErr 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) @@ -826,6 +1088,16 @@ Lemma list2vecOrFail {T}(l:list T)(n:nat)(error_message:nat->nat->string) : ???( 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". diff --git a/src/HaskCore.v b/src/HaskCore.v index 9024828..13a263e 100644 --- a/src/HaskCore.v +++ b/src/HaskCore.v @@ -7,7 +7,8 @@ Require Import Preamble. 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. @@ -22,6 +23,7 @@ Inductive CoreExpr {b:Type} := | 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. @@ -35,7 +37,9 @@ Extract Inductive CoreExpr => "CoreSyn.Case" "CoreSyn.Cast" "CoreSyn.Note" - "CoreSyn.Type" ]. + "CoreSyn.Type" + "CoreSyn.Coercion" + ]. Extract Inductive CoreBind => "CoreSyn.Bind" [ "CoreSyn.NonRec" "CoreSyn.Rec" ]. diff --git a/src/HaskCoreToWeak.v b/src/HaskCoreToWeak.v index abcd6b8..a287b20 100644 --- a/src/HaskCoreToWeak.v +++ b/src/HaskCoreToWeak.v @@ -7,7 +7,8 @@ Require Import Preamble. 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. @@ -15,10 +16,10 @@ Require Import HaskWeakVars. 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". @@ -27,13 +28,26 @@ Variable coreVarCoreName : CoreVar -> CoreName. Extract Inlined Constant co 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') @@ -44,16 +58,17 @@ Fixpoint coreTypeToWeakType' (ct:CoreType) : ???WeakType := | 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 @@ -68,9 +83,12 @@ Fixpoint coreTypeToWeakType' (ct:CoreType) : ???WeakType := 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 @@ -81,20 +99,38 @@ Fixpoint coreTypeToWeakType' (ct:CoreType) : ???WeakType := | 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. @@ -103,28 +139,52 @@ Definition isEsc (ce:@CoreExpr CoreVar) : ??(WeakExprVar * WeakTypeVar * CoreTyp 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. @@ -138,15 +198,33 @@ Fixpoint expectTyConApp (wt:WeakType)(acc:list WeakType) : ???(TyCon * list Weak | _ => 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!" @@ -167,32 +245,59 @@ Fixpoint coreExprToWeakExpr (ce:@CoreExpr CoreVar) : ???WeakExpr := 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 e) where e!=EType" end - | WCoerVar _ => Error "saw an (ELet )" + | 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 => @@ -200,7 +305,7 @@ Fixpoint coreExprToWeakExpr (ce:@CoreExpr CoreVar) : ???WeakExpr := 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" @@ -210,7 +315,7 @@ Fixpoint coreExprToWeakExpr (ce:@CoreExpr CoreVar) : ???WeakExpr := 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 => @@ -227,11 +332,11 @@ Fixpoint coreExprToWeakExpr (ce:@CoreExpr CoreVar) : ???WeakExpr := 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) @@ -241,7 +346,3 @@ Fixpoint coreExprToWeakExpr (ce:@CoreExpr CoreVar) : ???WeakExpr := OK (WECase ev scrutinee tbranches' tc lt (unleaves branches)) end end. - - - - diff --git a/src/HaskCoreTypes.v b/src/HaskCoreTypes.v index 8aa81ee..79ab342 100644 --- a/src/HaskCoreTypes.v +++ b/src/HaskCoreTypes.v @@ -9,9 +9,12 @@ Require Import Coq.Strings.String. 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". @@ -33,11 +36,40 @@ Extract Inductive CoreType => 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 => "(==)". diff --git a/src/HaskCoreVars.v b/src/HaskCoreVars.v index d158f05..8b0aabb 100644 --- a/src/HaskCoreVars.v +++ b/src/HaskCoreVars.v @@ -6,7 +6,8 @@ Generalizable All Variables. 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". diff --git a/src/HaskFlattener.v b/src/HaskFlattener.v new file mode 100644 index 0000000..c7625b8 --- /dev/null +++ b/src/HaskFlattener.v @@ -0,0 +1,1441 @@ +(*********************************************************************************************************************************) +(* 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 [ ]. diff --git a/src/HaskKinds.v b/src/HaskKinds.v index 3539e95..d575d12 100644 --- a/src/HaskKinds.v +++ b/src/HaskKinds.v @@ -37,6 +37,10 @@ Instance KindToString : ToString Kind := { toString := kindToString }. 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" diff --git a/src/HaskLiteralsAndTyCons.v b/src/HaskLiterals.v similarity index 69% rename from src/HaskLiteralsAndTyCons.v rename to src/HaskLiterals.v index 62d638b..c8a2651 100644 --- a/src/HaskLiteralsAndTyCons.v +++ b/src/HaskLiterals.v @@ -1,5 +1,5 @@ (*********************************************************************************************************************************) -(* HaskLiteralsAndTyCons: representation of compile-time constants (literals) *) +(* HaskLiterals: representation of compile-time constants (literals) *) (*********************************************************************************************************************************) Generalizable All Variables. @@ -7,12 +7,7 @@ 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". +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". @@ -21,11 +16,6 @@ Variable HaskFastString : Type. Extract Inlined Constant H 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 @@ -81,13 +71,3 @@ match lit with | 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". diff --git a/src/HaskProgrammingLanguage.v b/src/HaskProgrammingLanguage.v new file mode 100644 index 0000000..30a0ae8 --- /dev/null +++ b/src/HaskProgrammingLanguage.v @@ -0,0 +1,195 @@ +(*********************************************************************************************************************************) +(* 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. diff --git a/src/HaskProof.v b/src/HaskProof.v index a5e4abd..7f15825 100644 --- a/src/HaskProof.v +++ b/src/HaskProof.v @@ -10,11 +10,13 @@ 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 HaskLiteralsAndTyCons. +Require Import HaskLiterals. +Require Import HaskTyCons. Require Import HaskStrongTypes. Require Import HaskWeakVars. @@ -28,102 +30,113 @@ Inductive Judg := 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). @@ -157,6 +170,7 @@ Lemma no_rules_with_multiple_conclusions : forall c h, 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. @@ -168,4 +182,3 @@ Lemma systemfc_all_rules_one_conclusion : forall h c1 c2 (r:Rule h (c1,,c2)), Fa auto. Qed. - diff --git a/src/HaskProofFlattener.v b/src/HaskProofFlattener.v deleted file mode 100644 index 7b70e6e..0000000 --- a/src/HaskProofFlattener.v +++ /dev/null @@ -1,407 +0,0 @@ -(*********************************************************************************************************************************) -(* 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. - diff --git a/src/HaskProofStratified.v b/src/HaskProofStratified.v deleted file mode 100644 index ee475da..0000000 --- a/src/HaskProofStratified.v +++ /dev/null @@ -1,588 +0,0 @@ -(*********************************************************************************************************************************) -(* 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. diff --git a/src/HaskProofToLatex.v b/src/HaskProofToLatex.v index 4773eff..e85bb39 100644 --- a/src/HaskProofToLatex.v +++ b/src/HaskProofToLatex.v @@ -6,12 +6,14 @@ 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 HaskWeakVars. Require Import HaskWeakTypes. -Require Import HaskLiteralsAndTyCons. +Require Import HaskLiterals. +Require Import HaskTyCons. Require Import HaskStrongTypes. Require Import HaskStrong. Require Import HaskProof. @@ -101,7 +103,7 @@ Fixpoint typeToLatexMath (needparens:bool){κ}(t:RawHaskType (fun _ => LatexMath ; 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 "}")+++ @@ -126,7 +128,7 @@ Definition ltypeToLatexMath {Γ:TypeEnv}{κ}(t:LeveledHaskType Γ κ) : VarNameS | 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. @@ -145,9 +147,9 @@ Definition ltypeToLatexMath {Γ:TypeEnv}{κ}(t:LeveledHaskType Γ κ) : VarNameS 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)) @@ -158,65 +160,68 @@ Instance ToLatexMathJudgment : ToLatexMath Judg := 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. diff --git a/src/HaskProofToStrong.v b/src/HaskProofToStrong.v index 06f97a1..ab10fd8 100644 --- a/src/HaskProofToStrong.v +++ b/src/HaskProofToStrong.v @@ -6,6 +6,7 @@ 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 Coq.Init.Specif. @@ -27,11 +28,11 @@ Section HaskProofToStrong. 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. @@ -42,7 +43,7 @@ Section HaskProofToStrong. 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. @@ -122,7 +123,7 @@ Section HaskProofToStrong. 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. @@ -130,8 +131,8 @@ Section HaskProofToStrong. 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. @@ -164,7 +165,7 @@ Section HaskProofToStrong. 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. @@ -204,8 +205,8 @@ Section HaskProofToStrong. 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 _). @@ -222,60 +223,64 @@ Section HaskProofToStrong. 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. @@ -283,7 +288,7 @@ Section HaskProofToStrong. 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. @@ -291,20 +296,20 @@ Section HaskProofToStrong. 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)). @@ -312,7 +317,7 @@ Section HaskProofToStrong. 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). @@ -327,7 +332,7 @@ Section HaskProofToStrong. 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). @@ -342,16 +347,16 @@ Section HaskProofToStrong. 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. @@ -367,6 +372,8 @@ Section HaskProofToStrong. 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"). @@ -386,9 +393,9 @@ Section HaskProofToStrong. 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. @@ -411,11 +418,13 @@ Section HaskProofToStrong. 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. @@ -427,7 +436,7 @@ Section HaskProofToStrong. 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. @@ -441,10 +450,10 @@ Section HaskProofToStrong. 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. @@ -462,14 +471,15 @@ Section HaskProofToStrong. 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; @@ -479,7 +489,7 @@ Section HaskProofToStrong. simpl in *. apply ileaf in source. apply ILeaf. - destruct s as [sac pcb]. + destruct p as [sac pcb]. simpl in *. split. intros. @@ -501,27 +511,264 @@ Section HaskProofToStrong. 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 _ @@ -530,12 +777,10 @@ Section HaskProofToStrong. 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. @@ -562,14 +807,16 @@ Section HaskProofToStrong. 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. @@ -577,7 +824,7 @@ Section HaskProofToStrong. 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. @@ -601,19 +848,6 @@ Section HaskProofToStrong. 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_. @@ -635,39 +869,65 @@ Section HaskProofToStrong. 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. @@ -680,12 +940,12 @@ Section HaskProofToStrong. 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. @@ -705,8 +965,8 @@ Section HaskProofToStrong. 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. @@ -715,12 +975,21 @@ Section HaskProofToStrong. 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. @@ -758,53 +1027,18 @@ Section HaskProofToStrong. 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 *. @@ -818,7 +1052,10 @@ Section HaskProofToStrong. auto. refine (return OK _). exists ξ. - apply (ileaf it). + apply ileaf in it. + simpl in it. + apply it. + apply INone. Defined. End HaskProofToStrong. diff --git a/src/HaskSkolemizer.v b/src/HaskSkolemizer.v new file mode 100644 index 0000000..0d1cecb --- /dev/null +++ b/src/HaskSkolemizer.v @@ -0,0 +1,539 @@ +(*********************************************************************************************************************************) +(* 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. diff --git a/src/HaskStrong.v b/src/HaskStrong.v index c5f46dc..6629511 100644 --- a/src/HaskStrong.v +++ b/src/HaskStrong.v @@ -9,9 +9,11 @@ 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. +Require Import HaskCoreToWeak. Require Import HaskCoreVars. Section HaskStrong. @@ -24,77 +26,76 @@ 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 [[Γ]]. diff --git a/src/HaskStrongToProof.v b/src/HaskStrongToProof.v index c1e54aa..e93ddd9 100644 --- a/src/HaskStrongToProof.v +++ b/src/HaskStrongToProof.v @@ -6,6 +6,7 @@ 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 Coq.Init.Specif. @@ -15,17 +16,7 @@ Require Import HaskStrong. 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 *) @@ -121,31 +112,83 @@ Lemma strip_lemma a x t : stripOutVars (a::x) t = stripOutVars (a::nil) (stripOu 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. @@ -232,7 +275,7 @@ Lemma distinct3 {T}(a b c:list T) : distinct (app (app a b) c) -> distinct (app 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. @@ -250,7 +293,7 @@ Lemma strip_distinct' y : forall x, distinct (app x (leaves y)) -> 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'. @@ -258,74 +301,240 @@ Lemma strip_distinct' y : forall x, distinct (app x (leaves y)) -> stripOutVars 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 => [] @@ -340,23 +549,6 @@ match elrb with | 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 => [] @@ -380,7 +572,112 @@ Lemma stripping_nothing_is_inert 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 *) @@ -412,16 +709,16 @@ Definition arrangeContext (* 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 ( @@ -440,70 +737,131 @@ Definition arrangeContext 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, @@ -518,13 +876,13 @@ Definition arrangeContextAndWeaken'' 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 *. @@ -543,20 +901,20 @@ Definition arrangeContextAndWeaken'' 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. @@ -568,7 +926,7 @@ Lemma updating_stripped_tree_is_inert {Γ} (ξ:VV -> LeveledHaskType Γ ★) v t 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 -> @@ -578,7 +936,7 @@ Inductive LetRecSubproofs Γ Δ ξ lev : forall tree, ELetRecBindings Γ Δ ξ l 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. @@ -586,17 +944,19 @@ Lemma letRecSubproofsToND Γ Δ ξ lev tree branches : 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. @@ -605,11 +965,14 @@ Lemma letRecSubproofsToND' Γ Δ ξ lev τ tree : 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. @@ -617,10 +980,9 @@ Lemma letRecSubproofsToND' Γ Δ ξ lev τ tree : 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 *. @@ -633,28 +995,30 @@ Lemma letRecSubproofsToND' Γ Δ ξ lev τ tree : 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. @@ -676,14 +1040,29 @@ Lemma scbwv_coherent {tc}{Γ}{atypes:IList _ (HaskType Γ) _}{sac} : 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) = @@ -708,68 +1087,69 @@ Lemma case_lemma : forall Γ Δ ξ l tc tbranches atypes 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. @@ -783,22 +1163,22 @@ Definition expr2proof : 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. @@ -809,24 +1189,22 @@ Definition expr2proof : 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. @@ -845,7 +1223,6 @@ Definition expr2proof : auto. destruct case_ENote. - destruct t. eapply nd_comp; [ idtac | eapply nd_rule; apply RNote ]. apply e'. auto. @@ -873,37 +1250,52 @@ Definition expr2proof : 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. @@ -929,7 +1321,6 @@ Definition expr2proof : unfold ξ'1 in *. clear ξ'1. apply letRecSubproofsToND'. - admit. apply e'. apply subproofs. diff --git a/src/HaskStrongToWeak.v b/src/HaskStrongToWeak.v index e956dd6..8bb52e1 100644 --- a/src/HaskStrongToWeak.v +++ b/src/HaskStrongToWeak.v @@ -10,7 +10,8 @@ Require Import Coq.Strings.String. 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. @@ -61,7 +62,7 @@ Section HaskStrongToWeak. | 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) := @@ -78,6 +79,18 @@ Section HaskStrongToWeak. 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 @@ -94,32 +107,33 @@ Section HaskStrongToWeak. 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 @@ -131,7 +145,7 @@ Section HaskStrongToWeak. | 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 @@ -142,8 +156,8 @@ Section HaskStrongToWeak. | 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 @@ -156,7 +170,7 @@ Section HaskStrongToWeak. ; 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 [] @@ -170,7 +184,7 @@ Section HaskStrongToWeak. ; 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 @@ -181,12 +195,12 @@ Section HaskStrongToWeak. (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' @@ -206,7 +220,7 @@ Section HaskStrongToWeak. 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 diff --git a/src/HaskStrongTypes.v b/src/HaskStrongTypes.v index 224d70b..a7bd11a 100644 --- a/src/HaskStrongTypes.v +++ b/src/HaskStrongTypes.v @@ -8,7 +8,8 @@ Require Import Coq.Strings.String. 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. @@ -18,11 +19,11 @@ Require Import HaskCoreToWeak. 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 => @@ -65,11 +66,14 @@ Section Raw. | 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). @@ -110,6 +114,7 @@ Implicit Arguments TApp [ [TV] [κ₁] [κ₂] ]. 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 *) @@ -131,7 +136,7 @@ Definition InstantiatedCoercionEnv (TV:Kind->Type) CV (Γ:TypeEnv)(Δ:Coer (* 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). @@ -154,12 +159,13 @@ Definition HaskCoercion Γ Δ (hk:HaskCoercionKind Γ) := forall TV CV (ite:@Ins 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. @@ -168,36 +174,152 @@ Definition HaskAppT {Γ}{κ₁}{κ₂}(t1:HaskType Γ (κ₂⇛κ₁))(t2:HaskTy 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. @@ -233,21 +355,41 @@ Definition addCoercionToInstantiatedCoercionEnv {Γ}{Δ}{κ}{TV CV}(ice:Instanti 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 Γ κ) κ₂. @@ -258,34 +400,12 @@ 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. @@ -293,11 +413,80 @@ Definition weakCK' {Γ}{κ}(hck:HaskCoercionKind Γ) : HaskCoercionKind (app κ 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 -> @@ -324,10 +513,10 @@ Record StrongAltCon {tc:TyCon} := ; 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. @@ -347,7 +536,7 @@ Definition literalType (lit:HaskLiteral){Γ} : HaskType Γ ★. Notation "a ∼∼∼ b" := (@mkHaskCoercionKind _ _ a b) (at level 18). -Fixpoint update_ξ +Fixpoint update_xi `{EQD_VV:EqDecidable VV}{Γ} (ξ:VV -> LeveledHaskType Γ ★) (lev:HaskLevel Γ) @@ -355,12 +544,12 @@ Fixpoint update_ξ : 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. @@ -461,7 +650,7 @@ match t1 with | 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 @@ -556,7 +745,7 @@ Fixpoint typeToString' (needparens:bool)(n:nat){κ}(t:RawHaskType (fun _ => nat) 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 := @@ -570,3 +759,6 @@ Definition typeToString {Γ}{κ}(ht:HaskType Γ κ) : 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. diff --git a/src/HaskTyCons.v b/src/HaskTyCons.v new file mode 100644 index 0000000..1eb479a --- /dev/null +++ b/src/HaskTyCons.v @@ -0,0 +1,34 @@ +(*********************************************************************************************************************************) +(* 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". diff --git a/src/HaskWeak.v b/src/HaskWeak.v index d5d66c0..9d39f44 100644 --- a/src/HaskWeak.v +++ b/src/HaskWeak.v @@ -7,7 +7,9 @@ Require Import Preamble. 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. @@ -19,6 +21,8 @@ Inductive WeakAltCon := 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 @@ -27,6 +31,10 @@ Inductive 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 @@ -49,3 +57,59 @@ Inductive 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. +*) diff --git a/src/HaskWeakToCore.v b/src/HaskWeakToCore.v index 290d634..7d24277 100644 --- a/src/HaskWeakToCore.v +++ b/src/HaskWeakToCore.v @@ -8,7 +8,8 @@ Require Import General. 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. @@ -24,13 +25,6 @@ Variable sortAlts : forall {a}{b}, list (@triple CoreAltCon a b) -> list (@trip 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 @@ -58,7 +52,7 @@ Fixpoint weakTypeToCoreType (wt:WeakType) : CoreType := 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 @@ -66,12 +60,11 @@ Fixpoint weakExprToCoreExpr (me:WeakExpr) : @CoreExpr CoreVar := | 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)):: @@ -91,6 +84,10 @@ Fixpoint weakExprToCoreExpr (me:WeakExpr) : @CoreExpr CoreVar := (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) diff --git a/src/HaskWeakToStrong.v b/src/HaskWeakToStrong.v index 1b34865..f6dc701 100644 --- a/src/HaskWeakToStrong.v +++ b/src/HaskWeakToStrong.v @@ -10,7 +10,8 @@ Require Import Coq.Strings.String. 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. @@ -18,12 +19,19 @@ Require Import HaskWeakToCore. 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' @@ -32,12 +40,12 @@ Definition upφ {Γ}(tv:WeakTypeVar)(φ:TyVarResolver Γ) : TyVarResolver ((tv:K 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. @@ -52,7 +60,7 @@ Definition substPhi {Γ:TypeEnv}(κ κ':Kind)(θ:HaskType Γ κ) : HaskType (κ: 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. @@ -69,8 +77,8 @@ Definition substφ {Γ:TypeEnv}(lk:list Kind)(θ:IList _ (fun κ => HaskType Γ (* 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. @@ -81,9 +89,9 @@ Variable emptyφ : TyVarResolver nil. 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)). @@ -123,8 +131,9 @@ Definition weakTypeToType : forall {Γ:TypeEnv}(φ:TyVarResolver Γ)(t:WeakType) | 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' => @@ -139,7 +148,11 @@ Definition weakTypeToType : forall {Γ:TypeEnv}(φ:TyVarResolver Γ)(t:WeakType) 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 @@ -163,7 +176,7 @@ Definition weakTypeToType : forall {Γ:TypeEnv}(φ:TyVarResolver Γ)(t:WeakType) 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' ]. @@ -176,7 +189,7 @@ Definition weakTypeToType : forall {Γ:TypeEnv}(φ:TyVarResolver Γ)(t:WeakType) apply OK. eapply haskTypeOfSomeKind. unfold HaskType; intros. - apply TyFunApp. + apply (TyFunApp tc (fst (tyFunKind tc)) (snd (tyFunKind tc))). apply lt'. apply X. @@ -233,9 +246,9 @@ Definition weakTypeToType' {Γ} : IList Kind (HaskType Γ) (vec2list (tyConKinds 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'". @@ -320,17 +333,17 @@ Lemma weakCV' : forall {Γ}{Δ} Γ', 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. @@ -364,13 +377,13 @@ Definition mkStrongAltConPlusJunk' (tc : TyCon)(alt:WeakAltCon) : ???(@StrongAlt ; 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. @@ -380,7 +393,7 @@ Definition weakExprVarToWeakType : WeakExprVar -> WeakType := Variable weakCoercionToHaskCoercion : forall Γ Δ κ, WeakCoercion -> HaskCoercion Γ Δ κ. -Definition weakψ {Γ}{Δ:CoercionEnv Γ} {κ}(ψ:WeakCoerVar -> ???(HaskCoVar Γ Δ)) : +Definition weakPsi {Γ}{Δ:CoercionEnv Γ} {κ}(ψ:WeakCoerVar -> ???(HaskCoVar Γ Δ)) : WeakCoerVar -> ???(HaskCoVar Γ (κ::Δ)). intros. refine (ψ X >>= _). @@ -392,12 +405,10 @@ Definition weakψ {Γ}{Δ:CoercionEnv Γ} {κ}(ψ:WeakCoerVar -> ???(HaskCoVar 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+++ @@ -414,7 +425,7 @@ Definition castExpr (we:WeakExpr)(err_msg:string) {Γ} {Δ} {ξ} {τ} τ' (e:@Ex 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 Γ κ). @@ -478,6 +489,10 @@ Fixpoint doesWeakVarOccur (wev:WeakExprVar)(me:WeakExpr) : bool := | 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 => @@ -510,7 +525,22 @@ Fixpoint doesWeakVarOccurAlts (wev:WeakExprVar) | 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) @@ -521,7 +551,7 @@ Definition weakExprToStrongExpr : forall (ig:CoreVar -> bool) (τ:HaskType Γ ★) (lev:HaskLevel Γ), - WeakExpr -> ???(@Expr _ CoreVarEqDecidable Γ Δ ξ (τ @@ lev) ). + WeakExpr -> ???(@Expr _ CoreVarEqDecidable Γ Δ ξ τ lev ). refine (( fix weakExprToStrongExpr (Γ:TypeEnv) @@ -532,44 +562,44 @@ Definition weakExprToStrongExpr : forall (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') @@ -580,21 +610,23 @@ Definition weakExprToStrongExpr : forall 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 @@ -607,30 +639,30 @@ Definition weakExprToStrongExpr : forall 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)) @@ -644,8 +676,9 @@ Definition weakExprToStrongExpr : forall 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 => @@ -656,7 +689,7 @@ Definition weakExprToStrongExpr : forall 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)) => @@ -665,9 +698,9 @@ Definition weakExprToStrongExpr : forall >>= 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 [ _ ] @@ -678,7 +711,7 @@ Definition weakExprToStrongExpr : forall 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. @@ -700,6 +733,8 @@ Definition weakExprToStrongExpr : forall destruct (ξ c). simpl. apply e1. + rewrite mapleaves. + apply rb_distinct. destruct case_pf. set (distinct_decidable (vec2list exprvars')) as dec. diff --git a/src/HaskWeakTypes.v b/src/HaskWeakTypes.v index 5b73a41..9ec126e 100644 --- a/src/HaskWeakTypes.v +++ b/src/HaskWeakTypes.v @@ -8,7 +8,8 @@ Require Import General. 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 *) @@ -46,7 +47,7 @@ Instance WeakTypeVarEqDecidable : EqDecidable WeakTypeVar. 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 *) @@ -65,7 +66,7 @@ Inductive WeakCoercion : Type := 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!!! *) diff --git a/src/HaskWeakVars.v b/src/HaskWeakVars.v index 5169046..e7ab943 100644 --- a/src/HaskWeakVars.v +++ b/src/HaskWeakVars.v @@ -8,11 +8,17 @@ Require Import Coq.Strings.String. 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. @@ -31,9 +37,9 @@ Definition weakTypeVarToKind (tv:WeakTypeVar) : Kind := 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. @@ -41,17 +47,13 @@ Definition haskLiteralToWeakType lit : WeakType := 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) }. diff --git a/src/NaturalDeduction.v b/src/NaturalDeduction.v index 56d74cd..caa4dcf 100644 --- a/src/NaturalDeduction.v +++ b/src/NaturalDeduction.v @@ -142,6 +142,9 @@ Section Natural_Deduction. (* 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 ) @@ -229,18 +232,7 @@ Section Natural_Deduction. 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. @@ -306,6 +298,7 @@ Section Natural_Deduction. 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. @@ -325,53 +318,6 @@ Section Natural_Deduction. 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 *) @@ -511,42 +457,6 @@ Coercion sndr_ndr : SequentND_Relation >-> ND_Relation. 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. *) @@ -556,10 +466,39 @@ Notation "a ** b" := (nd_prod a b) : nd_scope. 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)) @@ -581,7 +520,8 @@ Section ND_Relation_Facts. (* 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 *) @@ -589,6 +529,44 @@ Section ND_Relation_Facts. 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 *) @@ -629,6 +607,7 @@ Definition nd_map | 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 _ @@ -644,6 +623,7 @@ Definition nd_map 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. @@ -677,6 +657,7 @@ Definition nd_map' | 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 _ @@ -692,6 +673,7 @@ Definition nd_map' 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. @@ -713,19 +695,6 @@ Inductive nd_property {Judgment}{Rule}(P:forall h c, @Rule h c -> Prop) : forall | 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) @@ -783,6 +752,9 @@ Section ToLatex. | 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 +++ diff --git a/src/NaturalDeductionCategory.v b/src/NaturalDeductionCategory.v index d721a97..9360bfa 100644 --- a/src/NaturalDeductionCategory.v +++ b/src/NaturalDeductionCategory.v @@ -136,9 +136,9 @@ Section Judgments_Category. ; 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. diff --git a/src/NaturalDeductionContext.v b/src/NaturalDeductionContext.v new file mode 100644 index 0000000..4da8922 --- /dev/null +++ b/src/NaturalDeductionContext.v @@ -0,0 +1,592 @@ +(*********************************************************************************************************************************) +(* 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. diff --git a/src/PCF.v b/src/PCF.v new file mode 100644 index 0000000..373519b --- /dev/null +++ b/src/PCF.v @@ -0,0 +1,283 @@ +(*********************************************************************************************************************************) +(* 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. diff --git a/src/ProgrammingLanguage.v b/src/ProgrammingLanguage.v index 0636a6e..83b435a 100644 --- a/src/ProgrammingLanguage.v +++ b/src/ProgrammingLanguage.v @@ -26,9 +26,7 @@ Require Import Enrichment_ch2_8. Require Import RepresentableStructure_ch7_2. Require Import FunctorCategories_ch7_7. -Require Import Enrichments. Require Import NaturalDeduction. -Require Import NaturalDeductionCategory. Section Programming_Language. @@ -47,218 +45,15 @@ 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 ]. + diff --git a/src/ProgrammingLanguageArrow.v b/src/ProgrammingLanguageArrow.v index 5dbce6d..5386d3e 100644 --- a/src/ProgrammingLanguageArrow.v +++ b/src/ProgrammingLanguageArrow.v @@ -30,7 +30,7 @@ Require Import FunctorCategories_ch7_7. Require Import NaturalDeduction. Require Import NaturalDeductionCategory. -Require Import ProgrammingLanguage. +Require Import ProgrammingLanguageCategory. Require Import FreydCategories. Require Import Enrichments. Require Import GeneralizedArrow. diff --git a/src/ProgrammingLanguageCategory.v b/src/ProgrammingLanguageCategory.v new file mode 100644 index 0000000..d415a35 --- /dev/null +++ b/src/ProgrammingLanguageCategory.v @@ -0,0 +1,650 @@ +(*********************************************************************************************************************************) +(* 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. + diff --git a/src/ProgrammingLanguageEnrichment.v b/src/ProgrammingLanguageEnrichment.v new file mode 100644 index 0000000..332a8ba --- /dev/null +++ b/src/ProgrammingLanguageEnrichment.v @@ -0,0 +1,52 @@ +(*********************************************************************************************************************************) +(* 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. + diff --git a/src/ProgrammingLanguageFlattening.v b/src/ProgrammingLanguageFlattening.v index 4438dd2..4c2a66b 100644 --- a/src/ProgrammingLanguageFlattening.v +++ b/src/ProgrammingLanguageFlattening.v @@ -27,7 +27,7 @@ Require Import Reification. 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. diff --git a/src/ProgrammingLanguageGeneralizedArrow.v b/src/ProgrammingLanguageGeneralizedArrow.v index bed54b6..8fe0391 100644 --- a/src/ProgrammingLanguageGeneralizedArrow.v +++ b/src/ProgrammingLanguageGeneralizedArrow.v @@ -30,7 +30,7 @@ Require Import NaturalDeductionCategory. Require Import Enrichments. Require Import Reification. Require Import GeneralizedArrow. -Require Import ProgrammingLanguage. +Require Import ProgrammingLanguageEnrichment. Section ProgrammingLanguageGeneralizedArrow. diff --git a/src/ProgrammingLanguageReification.v b/src/ProgrammingLanguageReification.v index 932c517..c1a06d8 100644 --- a/src/ProgrammingLanguageReification.v +++ b/src/ProgrammingLanguageReification.v @@ -28,6 +28,7 @@ Require Import Reification. Require Import NaturalDeduction. Require Import NaturalDeductionCategory. Require Import ProgrammingLanguage. +Require Import ProgrammingLanguageCategory. Require Import Enrichments. Section ProgrammingLanguageReification. diff --git a/src/categories b/src/categories index 0ecd73c..422dab8 160000 --- a/src/categories +++ b/src/categories @@ -1 +1 @@ -Subproject commit 0ecd73c172f67634fa956fb52b332e6effb5a04d +Subproject commit 422dab8d300548c294b95c0f4bbf27aecadbd745