module Cryptol.Parser.AST
(
ModName(..), modRange
, QName(..), mkQual, mkUnqual, unqual
, Name(..)
, Named(..)
, Pass(..)
, Schema(..)
, TParam(..), tpQName
, Kind(..)
, Type(..)
, Prop(..)
, Module(..)
, Program(..)
, TopDecl(..)
, Decl(..)
, TySyn(..)
, Bind(..)
, Pragma(..)
, ExportType(..)
, ExportSpec(..), exportBind, exportType
, isExportedBind, isExportedType
, TopLevel(..)
, Import(..), ImportSpec(..)
, Newtype(..)
, ReplInput(..)
, Expr(..)
, Literal(..), NumInfo(..)
, Match(..)
, Pattern(..)
, Selector(..)
, TypeInst(..)
, Located(..)
, LName, LQName, LString
, NoPos(..)
, cppKind, ppSelector
) where
import Cryptol.Parser.Position
import Cryptol.Prims.Syntax
import Cryptol.Utils.PP
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.List(intersperse)
import Data.Bits(shiftR)
import Data.Maybe (catMaybes)
import Data.Monoid (Monoid(..))
import Numeric(showIntAtBase)
newtype ModName = ModName [String]
deriving (Eq,Ord,Show)
data Name = Name String
| NewName Pass Int
deriving (Eq,Ord,Show)
data QName = QName (Maybe ModName) Name
deriving (Eq,Ord,Show)
mkQual :: ModName -> Name -> QName
mkQual = QName . Just
mkUnqual :: Name -> QName
mkUnqual = QName Nothing
unqual :: QName -> Name
unqual (QName _ n) = n
data Pass = NoPat | MonoValues
deriving (Eq,Ord,Show)
type LName = Located Name
type LQName = Located QName
type LString = Located String
newtype Program = Program [TopDecl]
deriving (Eq,Show)
data Module = Module { mName :: Located ModName
, mImports :: [Located Import]
, mDecls :: [TopDecl]
} deriving (Eq,Show)
modRange :: Module -> Range
modRange m = rCombs $ catMaybes
[ getLoc (mName m)
, getLoc (mImports m)
, getLoc (mDecls m)
, Just (Range { from = start, to = start, source = "" })
]
data TopDecl = Decl (TopLevel Decl)
| TDNewtype (TopLevel Newtype)
| Include (Located FilePath)
deriving (Eq,Show)
data Decl = DSignature [LQName] Schema
| DPragma [LQName] Pragma
| DBind Bind
| DPatBind Pattern Expr
| DType TySyn
| DLocated Decl Range
deriving (Eq,Show)
data Import = Import { iModule :: ModName
, iAs :: Maybe ModName
, iSpec :: Maybe ImportSpec
} deriving (Eq,Show)
data ImportSpec = Hiding [Name]
| Only [Name]
deriving (Eq,Show)
data TySyn = TySyn LQName [TParam] Type
deriving (Eq,Show)
data Bind = Bind { bName :: LQName
, bParams :: [Pattern]
, bDef :: Expr
, bSignature :: Maybe Schema
, bPragmas :: [Pragma]
, bMono :: Bool
} deriving (Eq,Show)
data Pragma = PragmaNote String
| PragmaProperty
deriving (Eq,Show)
data Newtype = Newtype { nName :: LQName
, nParams :: [TParam]
, nBody :: [Named Type]
} deriving (Eq,Show)
data ReplInput = ExprInput Expr
| LetInput Decl
deriving (Eq, Show)
data ExportType = Public
| Private
deriving (Eq,Show,Ord)
data TopLevel a = TopLevel { tlExport :: ExportType
, tlValue :: a
} deriving (Show,Eq,Ord)
instance Functor TopLevel where
fmap f tl = tl { tlValue = f (tlValue tl) }
data ExportSpec = ExportSpec { eTypes :: Set.Set QName
, eBinds :: Set.Set QName
} deriving (Show)
instance Monoid ExportSpec where
mempty = ExportSpec { eTypes = mempty, eBinds = mempty }
mappend l r = ExportSpec { eTypes = mappend (eTypes l) (eTypes r)
, eBinds = mappend (eBinds l) (eBinds r)
}
exportBind :: TopLevel QName -> ExportSpec
exportBind n
| tlExport n == Public = mempty { eBinds = Set.singleton (tlValue n) }
| otherwise = mempty
isExportedBind :: QName -> ExportSpec -> Bool
isExportedBind n = Set.member n . eBinds
exportType :: TopLevel QName -> ExportSpec
exportType n
| tlExport n == Public = mempty { eTypes = Set.singleton (tlValue n) }
| otherwise = mempty
isExportedType :: QName -> ExportSpec -> Bool
isExportedType n = Set.member n . eTypes
data NumInfo = BinLit Int
| OctLit Int
| DecLit
| HexLit Int
| CharLit
| PolyLit Int
deriving (Eq,Show)
data Literal = ECNum Integer NumInfo
| ECString String
deriving (Eq,Show)
data Expr = EVar QName
| ECon ECon
| ELit Literal
| ETuple [Expr]
| ERecord [Named Expr]
| ESel Expr Selector
| EList [Expr]
| EFromTo Type (Maybe Type) (Maybe Type)
| EInfFrom Expr (Maybe Expr)
| EComp Expr [[Match]]
| EApp Expr Expr
| EAppT Expr [TypeInst]
| EIf Expr Expr Expr
| EWhere Expr [Decl]
| ETyped Expr Type
| ETypeVal Type
| EFun [Pattern] Expr
| ELocated Expr Range
deriving (Eq,Show)
data TypeInst = NamedInst (Named Type)
| PosInst Type
deriving (Eq,Show)
data Selector = TupleSel Int (Maybe Int)
| RecordSel Name (Maybe [Name])
| ListSel Int (Maybe Int)
deriving (Eq,Show,Ord)
data Match = Match Pattern Expr
| MatchLet Bind
deriving (Eq,Show)
data Pattern = PVar LName
| PWild
| PTuple [Pattern]
| PRecord [ Named Pattern ]
| PList [ Pattern ]
| PTyped Pattern Type
| PSplit Pattern Pattern
| PLocated Pattern Range
deriving (Eq,Show)
data Named a = Named { name :: Located Name, value :: a }
deriving (Eq,Show)
instance Functor Named where
fmap f x = x { value = f (value x) }
data Schema = Forall [TParam] [Prop] Type (Maybe Range)
deriving (Eq,Show)
data Kind = KNum | KType
deriving (Eq,Show)
data TParam = TParam { tpName :: Name
, tpKind :: Maybe Kind
, tpRange :: Maybe Range
}
deriving (Eq,Show)
tpQName :: TParam -> QName
tpQName = mkUnqual . tpName
data Type = TFun Type Type
| TSeq Type Type
| TBit
| TNum Integer
| TChar Char
| TInf
| TUser QName [Type]
| TApp TFun [Type]
| TRecord [Named Type]
| TTuple [Type]
| TWild
| TLocated Type Range
deriving (Eq,Show)
data Prop = CFin Type
| CEqual Type Type
| CGeq Type Type
| CArith Type
| CCmp Type
| CLocated Prop Range
deriving (Eq,Show)
instance AddLoc Expr where
addLoc = ELocated
dropLoc (ELocated e _) = dropLoc e
dropLoc e = e
instance HasLoc Expr where
getLoc (ELocated _ r) = Just r
getLoc _ = Nothing
instance HasLoc TParam where
getLoc (TParam _ _ r) = r
instance AddLoc TParam where
addLoc (TParam a b _) l = TParam a b (Just l)
dropLoc (TParam a b _) = TParam a b Nothing
instance HasLoc Type where
getLoc (TLocated _ r) = Just r
getLoc _ = Nothing
instance AddLoc Type where
addLoc = TLocated
dropLoc (TLocated e _) = dropLoc e
dropLoc e = e
instance HasLoc Prop where
getLoc (CLocated _ r) = Just r
getLoc _ = Nothing
instance AddLoc Prop where
addLoc = CLocated
dropLoc (CLocated e _) = dropLoc e
dropLoc e = e
instance AddLoc Pattern where
addLoc = PLocated
dropLoc (PLocated e _) = dropLoc e
dropLoc e = e
instance HasLoc Pattern where
getLoc (PLocated _ r) = Just r
getLoc _ = Nothing
instance HasLoc Bind where
getLoc b = getLoc (bName b, bDef b)
instance HasLoc Match where
getLoc (Match p e) = getLoc (p,e)
getLoc (MatchLet b) = getLoc b
instance HasLoc a => HasLoc (Named a) where
getLoc l = getLoc (name l, value l)
instance HasLoc Schema where
getLoc (Forall _ _ _ r) = r
instance AddLoc Schema where
addLoc (Forall xs ps t _) r = Forall xs ps t (Just r)
dropLoc (Forall xs ps t _) = Forall xs ps t Nothing
instance HasLoc Decl where
getLoc (DLocated _ r) = Just r
getLoc _ = Nothing
instance AddLoc Decl where
addLoc d r = DLocated d r
dropLoc (DLocated d _) = dropLoc d
dropLoc d = d
instance HasLoc a => HasLoc (TopLevel a) where
getLoc = getLoc . tlValue
instance HasLoc TopDecl where
getLoc td = case td of
Decl tld -> getLoc tld
TDNewtype n -> getLoc n
Include lfp -> getLoc lfp
instance HasLoc Module where
getLoc m
| null locs = Nothing
| otherwise = Just (rCombs locs)
where
locs = catMaybes [ getLoc (mName m)
, getLoc (mImports m)
, getLoc (mDecls m)
]
instance HasLoc Newtype where
getLoc n
| null locs = Nothing
| otherwise = Just (rCombs locs)
where
locs = catMaybes [ getLoc (nName n), getLoc (nBody n) ]
ppL :: PP a => Located a -> Doc
ppL = pp . thing
ppNamed :: PP a => String -> Named a -> Doc
ppNamed s x = ppL (name x) <+> text s <+> pp (value x)
instance PP Module where
ppPrec _ m = text "module" <+> ppL (mName m) <+> text "where"
$$ vcat (map ppL (mImports m))
$$ vcat (map pp (mDecls m))
instance PP Program where
ppPrec _ (Program ds) = vcat (map pp ds)
instance PP TopDecl where
ppPrec _ top_decl =
case top_decl of
Decl d -> pp d
TDNewtype n -> pp n
Include l -> text "include" <+> text (show (thing l))
instance PP Decl where
ppPrec n decl =
case decl of
DSignature xs s -> commaSep (map ppL xs) <+> text ":" <+> pp s
DPatBind p e -> pp p <+> text "=" <+> pp e
DBind b -> ppPrec n b
DPragma xs p -> ppPragma xs p
DType ts -> ppPrec n ts
DLocated d _ -> ppPrec n d
instance PP Newtype where
ppPrec _ nt = hsep
[ text "newtype", ppL (nName nt), hsep (map pp (nParams nt)), char '='
, braces (commaSep (map (ppNamed ":") (nBody nt))) ]
instance PP Import where
ppPrec _ d = text "import" <+> sep [ pp (iModule d), mbAs, mbSpec ]
where
mbAs = maybe empty (\ name -> text "as" <+> pp name ) (iAs d)
mbSpec = maybe empty pp (iSpec d)
instance PP ImportSpec where
ppPrec _ s = case s of
Hiding names -> text "hiding" <+> parens (commaSep (map pp names))
Only names -> parens (commaSep (map pp names))
instance PP a => PP (TopLevel a) where
ppPrec _ tl = pp (tlValue tl)
instance PP Pragma where
ppPrec _ (PragmaNote x) = text x
ppPrec _ PragmaProperty = text "property"
ppPragma :: [LQName] -> Pragma -> Doc
ppPragma xs p =
text "/*" <+> text "pragma" <+> commaSep (map ppL xs) <+> text ":" <+> pp p
<+> text "*/"
instance PP Bind where
ppPrec _ b = sig $$ vcat [ ppPragma [f] p | p <- bPragmas b ] $$
hang (lhs <+> eq) 4 (pp (bDef b))
where f = bName b
sig = case bSignature b of
Nothing -> empty
Just s -> pp (DSignature [f] s)
eq = if bMono b then text ":=" else text "="
lhs = ppL f <+> fsep (map (ppPrec 3) (bParams b))
instance PP TySyn where
ppPrec _ (TySyn x xs t) = text "type" <+> ppL x <+> fsep (map (ppPrec 1) xs)
<+> text "=" <+> pp t
instance PP ModName where
ppPrec _ (ModName ns) = hcat (punctuate (text "::") (map text ns))
instance PP QName where
ppPrec _ (QName mb n) = mbNs <> pp n
where
mbNs = maybe empty (\ mn -> pp mn <> text "::") mb
instance PP Name where
ppPrec _ (Name x) = text x
ppPrec _ (NewName p x) = text "__" <> passName p <> int x
passName :: Pass -> Doc
passName pass =
case pass of
NoPat -> text "p"
MonoValues -> text "mv"
instance PP Literal where
ppPrec _ lit =
case lit of
ECNum n i -> ppNumLit n i
ECString s -> text (show s)
ppNumLit :: Integer -> NumInfo -> Doc
ppNumLit n info =
case info of
DecLit -> integer n
CharLit -> text (show (toEnum (fromInteger n) :: Char))
BinLit w -> pad 2 "0b" w
OctLit w -> pad 8 "0o" w
HexLit w -> pad 16 "0x" w
PolyLit w -> text "<|" <+> poly w <+> text "|>"
where
pad base pref w =
let txt = showIntAtBase base ("0123456789abcdef" !!) n ""
in text pref <> text (replicate (w length txt) '0') <> text txt
poly w = let (res,deg) = bits Nothing [] 0 n
z | w == 0 = []
| Just d <- deg, d + 1 == w = []
| otherwise = [polyTerm0 (w1)]
in fsep $ intersperse (text "+") $ z ++ map polyTerm res
polyTerm 0 = text "1"
polyTerm 1 = text "x"
polyTerm p = text "x" <> text "^^" <> int p
polyTerm0 0 = text "0"
polyTerm0 p = text "0" <> text "*" <> polyTerm p
bits d res p num
| num == 0 = (res,d)
| even num = bits d res (p + 1) (num `shiftR` 1)
| otherwise = bits (Just p) (p : res) (p + 1) (num `shiftR` 1)
wrap :: Int -> Int -> Doc -> Doc
wrap contextPrec myPrec doc = if myPrec < contextPrec then parens doc else doc
isInfixOp :: Expr -> Maybe (ECon, Assoc, Int)
isInfixOp (ELocated e _) = isInfixOp e
isInfixOp (ECon x) = do (a,p) <- Map.lookup x eBinOpPrec
return (x,a,p)
isInfixOp _ = Nothing
isPrefixOp :: Expr -> Maybe ECon
isPrefixOp (ELocated e _) = isPrefixOp e
isPrefixOp (ECon x) | x == ECNeg || x == ECCompl = Just x
isPrefixOp _ = Nothing
isEApp :: Expr -> Maybe (Expr, Expr)
isEApp (ELocated e _) = isEApp e
isEApp (EApp e1 e2) = Just (e1,e2)
isEApp _ = Nothing
asEApps :: Expr -> (Expr, [Expr])
asEApps expr = go expr []
where go e es = case isEApp e of
Nothing -> (e, es)
Just (e1, e2) -> go e1 (e2 : es)
isEInfix :: Expr -> Maybe (Infix ECon Expr)
isEInfix e =
do (e1,ieRight) <- isEApp e
(f,ieLeft) <- isEApp e1
(ieOp,ieAssoc,iePrec) <- isInfixOp f
return Infix { .. }
isTInfix :: Type -> Maybe (Infix TFun Type)
isTInfix (TLocated t _) = isTInfix t
isTInfix (TApp ieOp [ieLeft,ieRight]) =
do (ieAssoc,iePrec) <- Map.lookup ieOp tBinOpPrec
return Infix { .. }
isTInfix _ = Nothing
instance PP TypeInst where
ppPrec _ (PosInst t) = pp t
ppPrec _ (NamedInst x) = ppNamed "=" x
instance PP Expr where
ppPrec n expr =
case expr of
EVar x -> pp x
ECon x -> ppPrefix x
ELit x -> pp x
ETuple es -> parens (commaSep (map pp es))
ERecord fs -> braces (commaSep (map (ppNamed "=") fs))
EList es -> brackets (commaSep (map pp es))
EFromTo e1 e2 e3 -> brackets (pp e1 <> step <+> text ".." <+> end)
where step = maybe empty (\e -> comma <+> pp e) e2
end = maybe empty pp e3
EInfFrom e1 e2 -> brackets (pp e1 <> step <+> text "...")
where step = maybe empty (\e -> comma <+> pp e) e2
EComp e mss -> brackets (pp e <+> vcat (map arm mss))
where arm ms = text "|" <+> commaSep (map pp ms)
ETypeVal t -> text "`" <> ppPrec 5 t
EAppT e ts -> ppPrec 4 e <> text "`" <> braces (commaSep (map pp ts))
ESel e l -> ppPrec 4 e <> text "." <> pp l
EFun xs e -> wrap n 0 (text "\\" <> hsep (map (ppPrec 3) xs) <+>
text "->" <+> pp e)
EIf e1 e2 e3 -> wrap n 0 $ sep [ text "if" <+> pp e1
, text "then" <+> pp e2
, text "else" <+> pp e3 ]
ETyped e t -> wrap n 0 (ppPrec 2 e <+> text ":" <+> pp t)
EWhere e ds -> wrap n 0 (pp e
$$ text "where"
$$ nest 2 (vcat (map pp ds))
$$ text "")
_ | Just einf <- isEInfix expr
-> optParens (n>2) $ ppInfix 2 isEInfix einf
EApp e1 e2
| Just op <- isPrefixOp e1
-> wrap n 3 (pp op <> ppPrec 3 e2)
EApp _ _ -> let (e, es) = asEApps expr in
wrap n 3 (ppPrec 3 e <+> fsep (map (ppPrec 4) es))
ELocated e _ -> ppPrec n e
instance PP Selector where
ppPrec _ sel =
case sel of
TupleSel x sig -> int x <+> ppSig tupleSig sig
RecordSel x sig -> pp x <+> ppSig recordSig sig
ListSel x sig -> int x <+> ppSig listSig sig
where
tupleSig n = int n
recordSig xs = braces $ fsep $ punctuate comma $ map pp xs
listSig n = int n
ppSig f = maybe empty (\x -> text "/* of" <+> f x <+> text "*/")
ppSelector :: Selector -> Doc
ppSelector sel =
case sel of
TupleSel x _ -> ordinal x <+> text "field"
RecordSel x _ -> text "field" <+> pp x
ListSel x _ -> ordinal x <+> text "element"
instance PP Pattern where
ppPrec n pat =
case pat of
PVar x -> pp (thing x)
PWild -> char '_'
PTuple ps -> parens (commaSep (map pp ps))
PRecord fs -> braces (commaSep (map (ppNamed "=") fs))
PList ps -> brackets (commaSep (map pp ps))
PTyped p t -> wrap n 0 (ppPrec 1 p <+> text ":" <+> pp t)
PSplit p1 p2 -> wrap n 1 (ppPrec 1 p1 <+> text "#" <+> ppPrec 1 p2)
PLocated p _ -> ppPrec n p
instance PP Match where
ppPrec _ (Match p e) = pp p <+> text "<-" <+> pp e
ppPrec _ (MatchLet b) = pp b
instance PP Schema where
ppPrec _ (Forall xs ps t _) = sep [vars <+> preds, pp t]
where vars = case xs of
[] -> empty
_ -> braces (commaSep (map pp xs))
preds = case ps of
[] -> empty
_ -> parens (commaSep (map pp ps)) <+> text "=>"
instance PP Kind where
ppPrec _ KType = text "*"
ppPrec _ KNum = text "#"
cppKind :: Kind -> Doc
cppKind KType = text "a value type"
cppKind KNum = text "a numeric type"
instance PP TParam where
ppPrec n (TParam p Nothing _) = ppPrec n p
ppPrec n (TParam p (Just k) _) = wrap n 1 (pp p <+> text ":" <+> pp k)
instance PP Type where
ppPrec n ty =
case ty of
TWild -> text "_"
TTuple ts -> parens $ commaSep $ map pp ts
TRecord fs -> braces $ commaSep $ map (ppNamed ":") fs
TBit -> text "Bit"
TInf -> text "inf"
TNum x -> integer x
TChar x -> text (show x)
TSeq t1 TBit -> brackets (pp t1)
TSeq t1 t2 -> optParens (n > 3)
$ brackets (pp t1) <> ppPrec 3 t2
TApp _ [_,_]
| Just tinf <- isTInfix ty
-> optParens (n > 2)
$ ppInfix 2 isTInfix tinf
TApp f ts -> optParens (n > 2)
$ pp f <+> fsep (map (ppPrec 4) ts)
TUser f [] -> pp f
TUser f ts -> optParens (n > 2)
$ pp f <+> fsep (map (ppPrec 4) ts)
TFun t1 t2 -> optParens (n > 1)
$ sep [ppPrec 2 t1 <+> text "->", ppPrec 1 t2]
TLocated t _ -> ppPrec n t
instance PP Prop where
ppPrec n prop =
case prop of
CFin t -> text "fin" <+> ppPrec 4 t
CArith t -> text "Arith" <+> ppPrec 4 t
CCmp t -> text "Cmp" <+> ppPrec 4 t
CEqual t1 t2 -> ppPrec 2 t1 <+> text "==" <+> ppPrec 2 t2
CGeq t1 t2 -> ppPrec 2 t1 <+> text ">=" <+> ppPrec 2 t2
CLocated c _ -> ppPrec n c
class NoPos t where
noPos :: t -> t
instance NoPos (Located t) where
noPos x = x { srcRange = rng }
where rng = Range { from = Position 0 0, to = Position 0 0, source = "" }
instance NoPos t => NoPos (Named t) where
noPos t = Named { name = noPos (name t), value = noPos (value t) }
instance NoPos t => NoPos [t] where noPos = fmap noPos
instance NoPos t => NoPos (Maybe t) where noPos = fmap noPos
instance NoPos Program where
noPos (Program x) = Program (noPos x)
instance NoPos Module where
noPos m = Module { mName = mName m
, mImports = noPos (mImports m)
, mDecls = noPos (mDecls m)
}
instance NoPos TopDecl where
noPos decl =
case decl of
Decl x -> Decl (noPos x)
TDNewtype n -> TDNewtype(noPos n)
Include x -> Include (noPos x)
instance NoPos a => NoPos (TopLevel a) where
noPos tl = tl { tlValue = noPos (tlValue tl) }
instance NoPos Decl where
noPos decl =
case decl of
DSignature x y -> DSignature (noPos x) (noPos y)
DPragma x y -> DPragma (noPos x) (noPos y)
DPatBind x y -> DPatBind (noPos x) (noPos y)
DBind x -> DBind (noPos x)
DType x -> DType (noPos x)
DLocated x _ -> noPos x
instance NoPos Newtype where
noPos n = Newtype { nName = noPos (nName n)
, nParams = nParams n
, nBody = noPos (nBody n)
}
instance NoPos Bind where
noPos x = Bind { bName = noPos (bName x)
, bParams = noPos (bParams x)
, bDef = noPos (bDef x)
, bSignature = noPos (bSignature x)
, bPragmas = noPos (bPragmas x)
, bMono = bMono x
}
instance NoPos Pragma where
noPos p@(PragmaNote {}) = p
noPos p@(PragmaProperty) = p
instance NoPos TySyn where
noPos (TySyn x y z) = TySyn (noPos x) (noPos y) (noPos z)
instance NoPos Expr where
noPos expr =
case expr of
EVar x -> EVar x
ECon x -> ECon x
ELit x -> ELit x
ETuple x -> ETuple (noPos x)
ERecord x -> ERecord (noPos x)
ESel x y -> ESel (noPos x) y
EList x -> EList (noPos x)
EFromTo x y z -> EFromTo (noPos x) (noPos y) (noPos z)
EInfFrom x y -> EInfFrom (noPos x) (noPos y)
EComp x y -> EComp (noPos x) (noPos y)
EApp x y -> EApp (noPos x) (noPos y)
EAppT x y -> EAppT (noPos x) (noPos y)
EIf x y z -> EIf (noPos x) (noPos y) (noPos z)
EWhere x y -> EWhere (noPos x) (noPos y)
ETyped x y -> ETyped (noPos x) (noPos y)
ETypeVal x -> ETypeVal (noPos x)
EFun x y -> EFun (noPos x) (noPos y)
ELocated x _ -> noPos x
instance NoPos TypeInst where
noPos (PosInst ts) = PosInst (noPos ts)
noPos (NamedInst fs) = NamedInst (noPos fs)
instance NoPos Match where
noPos (Match x y) = Match (noPos x) (noPos y)
noPos (MatchLet b) = MatchLet (noPos b)
instance NoPos Pattern where
noPos pat =
case pat of
PVar x -> PVar (noPos x)
PWild -> PWild
PTuple x -> PTuple (noPos x)
PRecord x -> PRecord (noPos x)
PList x -> PList (noPos x)
PTyped x y -> PTyped (noPos x) (noPos y)
PSplit x y -> PSplit (noPos x) (noPos y)
PLocated x _ -> noPos x
instance NoPos Schema where
noPos (Forall x y z _) = Forall (noPos x) (noPos y) (noPos z) Nothing
instance NoPos TParam where
noPos (TParam x y _) = TParam x y Nothing
instance NoPos Type where
noPos ty =
case ty of
TWild -> TWild
TApp x y -> TApp x (noPos y)
TUser x y -> TUser x (noPos y)
TRecord x -> TRecord (noPos x)
TTuple x -> TTuple (noPos x)
TFun x y -> TFun (noPos x) (noPos y)
TSeq x y -> TSeq (noPos x) (noPos y)
TBit -> TBit
TInf -> TInf
TNum n -> TNum n
TChar n -> TChar n
TLocated x _ -> noPos x
instance NoPos Prop where
noPos prop =
case prop of
CEqual x y -> CEqual (noPos x) (noPos y)
CGeq x y -> CGeq (noPos x) (noPos y)
CFin x -> CFin (noPos x)
CArith x -> CArith (noPos x)
CCmp x -> CCmp (noPos x)
CLocated c _ -> noPos c