Simplify code to generate record constraints
This commit is contained in:
parent
ab41d0c0e8
commit
576e979483
3 changed files with 17 additions and 23 deletions
|
@ -16,7 +16,7 @@ data Type = Lambda Type Type
|
|||
| Record [(String,Type)] Type
|
||||
deriving (Eq, Show, Data, Typeable)
|
||||
|
||||
fieldMap :: [(String,Type)] -> Map.Map String [Type]
|
||||
fieldMap :: [(String,a)] -> Map.Map String [a]
|
||||
fieldMap fields =
|
||||
foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields
|
||||
|
||||
|
|
|
@ -108,31 +108,24 @@ constrain env (L _ _ expr) tipe =
|
|||
|
||||
Modify e fields ->
|
||||
exists $ \t -> do
|
||||
dummyFields <- Map.fromList <$> mapM dummyField fields
|
||||
cOld <- constrain env e (record dummyFields t)
|
||||
(fieldTypes, constraints) <- unzip <$> mapM field fields
|
||||
let cNew = tipe === record (Map.fromList fieldTypes) t
|
||||
return (CAnd (cOld : cNew : constraints))
|
||||
where
|
||||
dummyField (label, _) = do
|
||||
v <- var Flexible -- needs an ex
|
||||
return (label, [VarN v])
|
||||
oldVars <- forM fields $ \_ -> var Flexible
|
||||
let oldFields = SrcT.fieldMap (zip (map fst fields) (map VarN oldVars))
|
||||
cOld <- ex oldVars <$> constrain env e (record oldFields t)
|
||||
|
||||
field (label, value) = do
|
||||
v <- var Flexible -- needs an ex
|
||||
c <- ex [v] <$> constrain env value (VarN v)
|
||||
return ((label, [VarN v]), c)
|
||||
newVars <- forM fields $ \_ -> var Flexible
|
||||
let newFields = SrcT.fieldMap (zip (map fst fields) (map VarN newVars))
|
||||
let cNew = tipe === record newFields t
|
||||
|
||||
cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
|
||||
|
||||
return $ cOld /\ ex newVars (CAnd (cNew : cs))
|
||||
|
||||
Record fields ->
|
||||
do (pairs, cs) <- unzip <$> mapM field fields
|
||||
let fieldTypes = Map.fromList (map (second (\t -> [VarN t])) pairs)
|
||||
recordType = record fieldTypes (TermN EmptyRecord1)
|
||||
return $ ex (map snd pairs) (CAnd (tipe === recordType : cs))
|
||||
where
|
||||
field (name, body) = do
|
||||
v <- var Flexible -- needs an ex
|
||||
c <- constrain env body (VarN v)
|
||||
return ((name, v), c)
|
||||
do vars <- forM fields $ \_ -> var Flexible
|
||||
cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)
|
||||
let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars))
|
||||
recordType = record fields' (TermN EmptyRecord1)
|
||||
return . ex vars $ CAnd (tipe === recordType : cs)
|
||||
|
||||
Markdown _ ->
|
||||
return $ tipe === Env.get env Env.types "Element"
|
||||
|
|
|
@ -25,6 +25,7 @@ data TermN a
|
|||
| TermN (Term1 (TermN a))
|
||||
deriving Show
|
||||
|
||||
record :: Map.Map String [TermN a] -> TermN a -> TermN a
|
||||
record fs rec = TermN (Record1 fs rec)
|
||||
|
||||
type Type = TermN Variable
|
||||
|
|
Loading…
Reference in a new issue