You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
302 lines
8.9 KiB
302 lines
8.9 KiB
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
|
module Syntax where
|
|
|
|
import qualified Data.Map.Strict as Map
|
|
import qualified Data.Sequence as Seq
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Text as T
|
|
import Data.Map.Strict (Map)
|
|
import Data.Sequence (Seq)
|
|
import Data.Function (on)
|
|
import Data.IORef (IORef)
|
|
import Data.Text (Text)
|
|
import Data.Set (Set)
|
|
import Data.Data
|
|
|
|
import Presyntax.Presyntax (Plicity(..), Posn)
|
|
import Data.Monoid
|
|
import Debug.Trace (traceShow)
|
|
|
|
data WiredIn
|
|
= WiType
|
|
| WiPretype
|
|
| WiInterval
|
|
| WiI0
|
|
| WiI1
|
|
| WiIAnd
|
|
| WiIOr
|
|
| WiINot
|
|
| WiPathP
|
|
|
|
| WiIsOne -- Proposition associated with an element of the interval
|
|
| WiItIsOne -- 1 = 1
|
|
| WiIsOne1 -- i j -> [i] -> [ior i j]
|
|
| WiIsOne2 -- i j -> [j] -> [ior i j]
|
|
|
|
| WiPartial -- (φ : I) -> Type -> Typeω
|
|
| WiPartialP -- (φ : I) -> Partial r Type -> Typeω
|
|
|
|
| WiSub -- (A : Type) (φ : I) -> Partial φ A -> Typeω
|
|
| WiInS -- {A : Type} {φ : I} (u : A) -> Sub A φ (λ x -> u)
|
|
| WiOutS -- {A : Type} {φ : I} {u : Partial φ A} -> Sub A φ u -> A
|
|
|
|
| WiComp -- {A : I -> Type} {phi : I}
|
|
-- -> ((i : I) -> Partial phi (A i)
|
|
-- -> (A i0)[phi -> u i0] -> (A i1)[phi -> u i1]
|
|
|
|
| WiGlue -- (A : Type) {phi : I} (T : Partial phi Type) (e : PartialP phi (\o -> Equiv (T o) A)) -> Type
|
|
| WiGlueElem -- {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)} -> (t : PartialP phi T) -> Sub A phi (\o -> e o (t o)) -> Glue A phi T e
|
|
| WiUnglue -- {A : Type} {phi : I} {T : Partial phi Type} {e : PartialP phi (\o -> Equiv (T o) A)} -> Glue A phi T e -> A
|
|
|
|
| WiBool
|
|
| WiTrue
|
|
| WiFalse
|
|
| WiIf
|
|
deriving (Eq, Show, Ord)
|
|
|
|
data Term
|
|
= Ref Name
|
|
| App Plicity Term Term
|
|
| Lam Plicity Name Term
|
|
| Pi Plicity Name Term Term
|
|
| Let [(Name, Term, Term)] Term
|
|
| Meta MV
|
|
| Type
|
|
| Typeω
|
|
|
|
| Sigma Name Term Term
|
|
| Pair Term Term
|
|
| Proj1 Term
|
|
| Proj2 Term
|
|
|
|
| I
|
|
| I0 | I1
|
|
| IAnd Term Term
|
|
| IOr Term Term
|
|
| INot Term
|
|
|
|
| PathP Term Term Term
|
|
-- ^ PathP : (A : I -> Type) -> A i0 -> A i1 -> Type
|
|
| IElim Term Term Term Term Term
|
|
-- ^ IElim : {A : I -> Type} {x : A i0} {y : A i1} (p : PathP A x y) (i : I) -> A i
|
|
| PathIntro Term Term Term Term
|
|
-- ^ PathIntro : (A : I -> Type) (f : (i : I) -> A i) -> PathP A (f i0) (f i1)
|
|
-- ~~~~~~~~~ not printed at all
|
|
|
|
| IsOne Term
|
|
| IsOne1 Term
|
|
| IsOne2 Term
|
|
| ItIsOne
|
|
|
|
| Partial Term Term
|
|
| PartialP Term Term
|
|
|
|
| System (Map Term Term)
|
|
|
|
| Sub Term Term Term
|
|
| Inc Term Term Term
|
|
| Ouc Term Term Term Term
|
|
|
|
| Comp Term Term Term Term
|
|
|
|
| GlueTy Term Term Term Term
|
|
| Glue Term Term Term Term Term Term
|
|
| Unglue Term Term Term Term Term
|
|
|
|
-- ugly. TODO: proper inductive types
|
|
| Bool | Tt | Ff | If Term Term Term Term
|
|
deriving (Eq, Show, Ord, Data)
|
|
|
|
data MV =
|
|
MV { mvName :: Text
|
|
, mvCell :: {-# UNPACK #-} !(IORef (Maybe Value))
|
|
, mvType :: NFType
|
|
, mvSpan :: Maybe (Text, Posn, Posn)
|
|
}
|
|
|
|
instance Eq MV where
|
|
(==) = (==) `on` mvName
|
|
instance Ord MV where
|
|
(<=) = (<=) `on` mvName
|
|
instance Show MV where
|
|
show x = show (mvName x, mvSpan x)
|
|
|
|
instance Data MV where
|
|
toConstr _ = error "toConstr"
|
|
gunfold _ _ = error "gunfold"
|
|
dataTypeOf _ = mkNoRepType "MV"
|
|
|
|
|
|
data Name
|
|
= Bound {getNameText :: Text, getNameNum :: !Int}
|
|
| Defined {getNameText :: Text, getNameNum :: !Int}
|
|
deriving (Eq, Show, Ord, Data)
|
|
|
|
type NFType = Value
|
|
type NFEndp = Value
|
|
type NFLine = Value
|
|
type NFSort = Value
|
|
type NFPartial = Value
|
|
|
|
data Value
|
|
= VNe Head (Seq Projection)
|
|
| VLam Plicity Closure
|
|
| VPi Plicity Value Closure
|
|
| VSigma Value Closure
|
|
| VPair Value Value
|
|
|
|
| GluedVl Head (Seq Projection) Value
|
|
|
|
| VType | VTypeω
|
|
|
|
| VI
|
|
| VI0 | VI1
|
|
| VIAnd NFEndp NFEndp
|
|
| VIOr NFEndp NFEndp
|
|
| VINot NFEndp
|
|
|
|
| VPath NFLine Value Value
|
|
| VLine NFLine Value Value Value
|
|
|
|
| VIsOne NFEndp
|
|
| VItIsOne
|
|
| VIsOne1 NFEndp
|
|
| VIsOne2 NFEndp
|
|
|
|
| VPartial NFEndp Value
|
|
| VPartialP NFEndp Value
|
|
| VSystem (Map Value Value)
|
|
|
|
| VSub NFSort NFEndp Value
|
|
| VInc NFSort NFEndp Value
|
|
|
|
| VComp NFSort NFEndp Value Value
|
|
|
|
| VGlueTy NFSort NFEndp NFPartial NFPartial
|
|
| VGlue NFSort NFEndp NFPartial NFPartial NFPartial Value
|
|
| VUnglue NFSort NFEndp NFPartial NFPartial Value
|
|
|
|
| VBool
|
|
| VTt
|
|
| VFf
|
|
| VIf Value Value Value Value
|
|
deriving (Eq, Show, Ord)
|
|
|
|
pattern VVar :: Name -> Value
|
|
pattern VVar x = VNe (HVar x) Seq.Empty
|
|
|
|
quoteWith :: Set Name -> Value -> Term
|
|
quoteWith names (VNe h sp) = foldl goSpine (goHead h) sp where
|
|
goHead (HVar v) = Ref v
|
|
goHead (HMeta m) = Meta m
|
|
|
|
goSpine t (PApp p v) = App p t (quoteWith names v)
|
|
goSpine t (PIElim l x y i) = IElim (quote l) (quote x) (quote y) t (quote i)
|
|
goSpine t PProj1 = Proj1 t
|
|
goSpine t PProj2 = Proj2 t
|
|
goSpine t (POuc a phi u) = Ouc (quote a) (quote phi) (quote u) t
|
|
|
|
quoteWith names (GluedVl h sp (VLam p (Closure n k))) =
|
|
quoteWith names (VLam p (Closure n (\a -> GluedVl h (sp Seq.:|> PApp p a) (k a))))
|
|
|
|
quoteWith names (GluedVl h sp vl)
|
|
| GluedVl _ _ inner <- vl = quoteWith names (GluedVl h sp inner)
|
|
| Seq.Empty <- sp = quoteWith names vl
|
|
| alwaysShort vl = quoteWith names vl
|
|
| otherwise = quoteWith names (VNe h sp)
|
|
|
|
quoteWith names (VLam p (Closure n k)) =
|
|
let n' = refresh Nothing names n
|
|
in Lam p n' (quoteWith (Set.insert n' names) (k (VVar n')))
|
|
|
|
quoteWith names (VPi p d (Closure n k)) =
|
|
let n' = refresh (Just d) names n
|
|
in Pi p n' (quoteWith names d) (quoteWith (Set.insert n' names) (k (VVar n')))
|
|
|
|
quoteWith names (VSigma d (Closure n k)) =
|
|
let n' = refresh (Just d) names n
|
|
in Sigma n' (quoteWith names d) (quoteWith (Set.insert n' names) (k (VVar n')))
|
|
|
|
quoteWith names (VPair a b) = Pair (quoteWith names a) (quoteWith names b)
|
|
quoteWith _ VType = Type
|
|
quoteWith _ VTypeω = Typeω
|
|
|
|
quoteWith _ VI = I
|
|
quoteWith _ VI0 = I0
|
|
quoteWith _ VI1 = I1
|
|
quoteWith names (VIAnd x y) = IAnd (quoteWith names x) (quoteWith names y)
|
|
quoteWith names (VIOr x y) = IOr (quoteWith names x) (quoteWith names y)
|
|
quoteWith names (VINot x) = INot (quoteWith names x)
|
|
|
|
quoteWith names (VPath line x y) = PathP (quoteWith names line) (quoteWith names x) (quoteWith names y)
|
|
quoteWith names (VLine p x y f) = PathIntro (quoteWith names p) (quoteWith names x) (quoteWith names y) (quoteWith names f)
|
|
|
|
quoteWith names (VIsOne v) = IsOne (quoteWith names v)
|
|
quoteWith names (VIsOne1 v) = IsOne1 (quoteWith names v)
|
|
quoteWith names (VIsOne2 v) = IsOne2 (quoteWith names v)
|
|
quoteWith _ VItIsOne = ItIsOne
|
|
|
|
quoteWith names (VPartial x y) = Partial (quoteWith names x) (quoteWith names y)
|
|
quoteWith names (VPartialP x y) = PartialP (quoteWith names x) (quoteWith names y)
|
|
quoteWith names (VSystem fs) = System (Map.fromList (map (\(x, y) -> (quoteWith names x, quoteWith names y)) (Map.toList fs)))
|
|
quoteWith names (VSub a b c) = Sub (quoteWith names a) (quoteWith names b) (quoteWith names c)
|
|
quoteWith names (VInc a b c) = Inc (quoteWith names a) (quoteWith names b) (quoteWith names c)
|
|
quoteWith names (VComp a phi u a0) = Comp (quoteWith names a) (quoteWith names phi) (quoteWith names u) (quoteWith names a0)
|
|
|
|
quoteWith names (VGlueTy a phi t e) = GlueTy (quoteWith names a) (quoteWith names phi) (quoteWith names t) (quoteWith names e)
|
|
quoteWith names (VGlue a phi ty e t x) = Glue (quoteWith names a) (quoteWith names phi) (quoteWith names ty) (quoteWith names e) (quoteWith names t) (quoteWith names x)
|
|
quoteWith names (VUnglue a phi ty e x) = Unglue (quoteWith names a) (quoteWith names phi) (quoteWith names ty) (quoteWith names e) (quoteWith names x)
|
|
|
|
quoteWith _ames VBool = Bool
|
|
quoteWith _ames VTt = Tt
|
|
quoteWith _ames VFf = Ff
|
|
quoteWith names (VIf a b c d) = If (quoteWith names a) (quoteWith names b) (quoteWith names c) (quoteWith names d)
|
|
|
|
alwaysShort :: Value -> Bool
|
|
alwaysShort VBool{} = True
|
|
alwaysShort VTt{} = True
|
|
alwaysShort VFf{} = True
|
|
alwaysShort VVar{} = True
|
|
alwaysShort _ = False
|
|
|
|
refresh :: Maybe Value -> Set Name -> Name -> Name
|
|
refresh (Just VI) n _ = refresh Nothing n (Bound (T.pack "phi") 0)
|
|
refresh x s n
|
|
| T.singleton '_' == getNameText n = n
|
|
| n `Set.notMember` s = n
|
|
| otherwise = refresh x s (Bound (getNameText n <> T.singleton '\'') 0)
|
|
|
|
quote :: Value -> Term
|
|
quote = quoteWith mempty
|
|
|
|
data Closure
|
|
= Closure
|
|
{ clArgName :: Name
|
|
, clCont :: Value -> Value
|
|
}
|
|
|
|
instance Show Closure where
|
|
show (Closure n c) = "Closure \\" ++ show n ++ " -> " ++ show (c (VVar n))
|
|
|
|
instance Eq Closure where
|
|
Closure _ k == Closure _ k' =
|
|
k (VVar (Bound (T.pack "_") 0)) == k' (VVar (Bound (T.pack "_") 0))
|
|
|
|
instance Ord Closure where
|
|
Closure _ k <= Closure _ k' =
|
|
k (VVar (Bound (T.pack "_") 0)) <= k' (VVar (Bound (T.pack "_") 0))
|
|
|
|
data Head
|
|
= HVar Name
|
|
| HMeta MV
|
|
deriving (Eq, Show, Ord)
|
|
|
|
data Projection
|
|
= PApp Plicity Value
|
|
| PIElim Value Value Value NFEndp
|
|
| PProj1
|
|
| PProj2
|
|
| POuc NFSort NFEndp Value
|
|
deriving (Eq, Show, Ord)
|