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.
169 lines
4.1 KiB
169 lines
4.1 KiB
{-# LANGUAGE PatternSynonyms #-}
|
|
module Syntax where
|
|
|
|
import Data.Function (on)
|
|
import Data.Text (Text)
|
|
|
|
import Presyntax.Presyntax (Plicity(..))
|
|
import qualified Data.Text as T
|
|
import Data.IORef (IORef)
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as Set
|
|
import Data.Sequence (Seq)
|
|
import qualified Data.Sequence as Seq
|
|
|
|
data WiredIn
|
|
= WiType
|
|
| WiPretype
|
|
| WiInterval
|
|
| WiI0
|
|
| WiI1
|
|
| WiIAnd
|
|
| WiIOr
|
|
| WiINot
|
|
| WiPathP
|
|
deriving (Eq, Show, Ord)
|
|
|
|
data Term
|
|
= Ref Name
|
|
| App Plicity Term Term
|
|
| Lam Plicity Text Term
|
|
| Pi Plicity Text Term Term
|
|
| Meta MV
|
|
| Type
|
|
| Typeω
|
|
|
|
| Sigma Text 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
|
|
-- ^ PathIntro : (A : I -> Type) (f : (i : I) -> A i) -> PathP A (f i0) (f i1)
|
|
-- ~~~~~~~~~ not printed at all
|
|
deriving (Eq, Show, Ord)
|
|
|
|
data MV =
|
|
MV { mvName :: Text
|
|
, mvCell :: {-# UNPACK #-} !(IORef (Maybe Value))
|
|
}
|
|
|
|
instance Eq MV where
|
|
(==) = (==) `on` mvName
|
|
instance Ord MV where
|
|
(<=) = (<=) `on` mvName
|
|
instance Show MV where
|
|
show = ('?':) . T.unpack . mvName
|
|
|
|
data Name
|
|
= Bound Text
|
|
| Defined Text
|
|
deriving (Eq, Show, Ord)
|
|
|
|
type NFType = Value
|
|
type NFEndp = Value
|
|
|
|
data Value
|
|
= VNe Head (Seq Projection)
|
|
| VLam Plicity Closure
|
|
| VPi Plicity Value Closure
|
|
| VSigma Value Closure
|
|
| VPair Value Value
|
|
|
|
| VType | VTypeω
|
|
|
|
| VI
|
|
| VI0 | VI1
|
|
| VIAnd Value Value
|
|
| VIOr Value Value
|
|
| VINot Value
|
|
|
|
| VPath Value Value Value
|
|
| VLine Value Value
|
|
deriving (Eq, Show, Ord)
|
|
|
|
pattern VVar :: Name -> Value
|
|
pattern VVar x = VNe (HVar x) Seq.Empty
|
|
|
|
quoteWith :: Set Text -> 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
|
|
|
|
quoteWith names (VLam p (Closure n k)) =
|
|
let n' = refresh names n
|
|
in Lam p n' (quoteWith (Set.insert n' names) (k (VVar (Bound n'))))
|
|
|
|
quoteWith names (VPi p d (Closure n k)) =
|
|
let n' = refresh names n
|
|
in Pi p n' (quoteWith names d) (quoteWith (Set.insert n' names) (k (VVar (Bound n'))))
|
|
|
|
quoteWith names (VSigma d (Closure n k)) =
|
|
let n' = refresh names n
|
|
in Sigma n' (quoteWith names d) (quoteWith (Set.insert n' names) (k (VVar (Bound 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 f) = PathIntro (quoteWith names p) (quoteWith names f)
|
|
|
|
refresh :: Set Text -> Text -> Text
|
|
refresh s n
|
|
| T.singleton '_' == n = n
|
|
| n `Set.notMember` s = n
|
|
| otherwise = refresh s (n <> T.singleton '\'')
|
|
|
|
quote :: Value -> Term
|
|
quote = quoteWith mempty
|
|
|
|
data Closure
|
|
= Closure
|
|
{ clArgName :: Text
|
|
, clCont :: Value -> Value
|
|
}
|
|
|
|
instance Show Closure where
|
|
show (Closure n c) = "Closure \\" ++ show n ++ " -> " ++ show (c (VVar (Bound n)))
|
|
|
|
instance Eq Closure where
|
|
Closure _ k == Closure _ k' =
|
|
k (VVar (Bound (T.pack "_"))) == k' (VVar (Bound (T.pack "_")))
|
|
|
|
instance Ord Closure where
|
|
Closure _ k <= Closure _ k' =
|
|
k (VVar (Bound (T.pack "_"))) <= k' (VVar (Bound (T.pack "_")))
|
|
|
|
data Head
|
|
= HVar Name
|
|
| HMeta MV
|
|
deriving (Eq, Show, Ord)
|
|
|
|
data Projection
|
|
= PApp Plicity Value
|
|
| PIElim Value Value Value NFEndp
|
|
| PProj1
|
|
| PProj2
|
|
deriving (Eq, Show, Ord)
|