Commit fd390fc2 authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

First modifications of kind and syntax check to handle Haskell's record syntax

parent 917868b1
......@@ -4,6 +4,7 @@
Copyright : (c) 2000 - 2007 Wolfgang Lux
Martin Engelke
Björn Peemöller
2014 Jan Rasmus Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -53,17 +54,16 @@ import Env.TypeConstructor (TCEnv, tcArity)
kindCheck :: TCEnv -> Module -> (Module, [Message])
kindCheck tcEnv mdl@(Module _ m _ _ ds) =
case findMultiples $ map typeConstr tds of
[] -> runKCM (checkModule mdl) state
[] -> runKCM (mapM checkModule mdl) state
tss -> (mdl, map errMultipleDeclaration tss)
where
tds = filter isTypeDecl ds
kEnv = foldr (bindKind m) (fmap tcArity tcEnv) tds
state = KCState m kEnv []
where tds = filter isTypeDecl ds
kEnv = foldr (bindKind m) (fmap tcArity tcEnv) tds
state = KCState m kEnv []
-- Kind Check Monad
type KCM = S.State KCState
-- |Internal state of the kind check
-- |Internal state of the Kind Check
data KCState = KCState
{ moduleIdent :: ModuleIdent
, kindEnv :: KindEnv
......@@ -143,12 +143,22 @@ checkConstrDecl tvs (ConOpDecl p evs ty1 op ty2) = do
ty1' <- checkClosedType tvs' ty1
ty2' <- checkClosedType tvs' ty2
return $ ConOpDecl p evs' ty1' op ty2'
-- jrt: Added for support of Haskell's record syntax
checkConstrDecl tvs (RecordDecl p evs c fs) = do
evs' <- checkTypeLhs evs
fs' <- mapM (\ (i, ty) -> (i, checkClosedType (evs' ++ tvs) ty)) fs
return $ RecordDecl p evs' c fs'
checkNewConstrDecl :: [Ident] -> NewConstrDecl -> KCM NewConstrDecl
checkNewConstrDecl tvs (NewConstrDecl p evs c ty) = do
evs' <- checkTypeLhs evs
ty' <- checkClosedType (evs' ++ tvs) ty
return $ NewConstrDecl p evs' c ty'
-- jrt: Added for support of Haskell's record syntax
checkNewConstrDecl tvs (NewRecordDecl p evs c (i, ty))
evs' <- checkTypeLhs evs
ty' <- checkClosedType (evs' ++ tvs) ty
return $ NewRecordDecl p evs' c (i, ty')
-- |Check the left-hand-side of a type declaration for
-- * Anonymous type variables are allowed
......@@ -210,6 +220,10 @@ checkExpr (RecordConstr fs) = RecordConstr <$> mapM checkFieldExpr fs
checkExpr (RecordSelection e l) = flip RecordSelection l <$> checkExpr e
checkExpr (RecordUpdate fs e) = RecordUpdate <$> mapM checkFieldExpr fs
<*> checkExpr e
-- jrt: Added for support of Haskell's record syntax
checkExpr (HsRecordConstr c fs) = HsRecordConstr c <$> mapM checkFieldExpr fs
checkExpr (HsRecordUpdate e fs) = HsRecordUpdate <$> checkExpr e
<*> mapM checkFieldExpr fs
checkStmt :: Statement -> KCM Statement
checkStmt (StmtExpr p e) = StmtExpr p <$> checkExpr e
......
......@@ -24,11 +24,13 @@
module Checks.SyntaxCheck (syntaxCheck) where
import Control.Monad (forM_, liftM, liftM2, liftM3, unless, when)
import Control.Monad ( forM_, liftM, liftM2, liftM3, unless
, when)
import qualified Control.Monad.State as S (State, runState, gets, modify)
import Data.List ((\\), insertBy, nub, partition)
import Data.Maybe (isJust, isNothing, maybeToList)
import qualified Data.Set as Set (empty, insert, member)
import Data.List ((\\), insertBy, nub, partition)
import Data.Maybe ( fromJust, isJust, isNothing
, maybeToList)
import qualified Data.Set as Set (empty, insert, member)
import Curry.Base.Ident
import Curry.Base.Position
......@@ -159,7 +161,7 @@ inNestedScope act = withLocalEnv (incNesting >> act)
report :: Message -> SCM ()
report msg = S.modify $ \ s -> s { errors = msg : errors s }
-- |Everything is checked.
-- |Everything is checked
ok :: SCM ()
ok = return ()
......@@ -189,7 +191,7 @@ data RenameInfo
-- |Arity of global function
| GlobalVar QualIdent Int
-- |Arity of local function
| LocalVar Ident Int
| LocalVar Ident Int
deriving (Eq, Show)
ppRenameInfo :: RenameInfo -> Doc
......@@ -222,7 +224,7 @@ bindLocal = bindNestEnv
bindTypeDecl :: Decl -> SCM ()
bindTypeDecl (DataDecl _ _ _ cs) = mapM_ bindConstr cs
bindTypeDecl (NewtypeDecl _ _ _ nc) = bindNewConstr nc
bindTypeDecl (TypeDecl _ t _ (RecordType fs)) = bindRecordLabels t
bindTypeDecl (TypeDecl _ t _ (RecordType fs)) = bindRecordLabel t
(concatMap fst fs)
bindTypeDecl _ = return ()
......@@ -233,14 +235,26 @@ bindConstr (ConstrDecl _ _ c tys) = do
bindConstr (ConOpDecl _ _ _ op _) = do
m <- getModuleIdent
modifyRenameEnv $ bindGlobal m op (Constr (qualifyWith m op) 2)
-- jrt: Added for support of Haskell's record syntax
bindConstr (RecordDecl _ _ c fs) = do
mapM_ (bindRecordLabel c allLabels) allLabels
m <- getModuleIdent
modifyRenameEnv $ bindGlobal m c (Constr (qualifyWith m c) arity)
where allLabels = concatMap fst fs
arity = foldr (\f a -> a + length (fst f)) 0 fs
bindNewConstr :: NewConstrDecl -> SCM ()
bindNewConstr (NewConstrDecl _ _ c _) = do
m <- getModuleIdent
modifyRenameEnv $ bindGlobal m c (Constr (qualifyWith m c) 1)
-- jrt: Added for support of Haskell's record syntax
bindNewConstr (NewRecordDecl _ _ c (l,_)) = do
bindRecordLabel c [l] l
m <- getModuleIdent
modifyRenameEnv $ bindGlobal m c (Constr (qualifyWith m c) 1)
bindRecordLabels :: Ident -> [Ident] -> SCM ()
bindRecordLabels t labels = do
bindRecordLabel :: Ident -> [Ident] -> SCM ()
bindRecordLabel t labels = do
m <- getModuleIdent
forM_ labels $ \l -> do
new <- (null . lookupVar l) `liftM` getRenameEnv
......@@ -313,12 +327,12 @@ qualLookupListCons v env
checkModule :: Module -> SCM (Module, [KnownExtension])
checkModule (Module ps m es is ds) = do
mapM_ checkPragma ps
mapM_ checkPragma ps
mapM_ bindTypeDecl tds
ds' <- liftM2 (++) (mapM checkTypeDecl tds) (checkTopDecls vds)
exts <- getExtensions
return (Module ps m es is ds', exts)
where (tds, vds) = partition isTypeDecl ds
where (tds, vds) = partition isTypeDecl decls
checkPragma :: ModulePragma -> SCM ()
checkPragma (LanguagePragma _ exts) = mapM_ checkExtension exts
......@@ -656,21 +670,21 @@ checkRecordPattern p fs t = do
env <- getRenameEnv
case lookupVar l env of
[RecordLabel r ls] -> do
case findDouble ls' of
Just l' -> report $ errDuplicateLabel l'
_ -> ok
case t of
Nothing -> do
when (isJust duplicate) $ report $ errDuplicateLabel
$ fromJust duplicate
if isNothing t
then do
when (not $ null missings) $ report $ errMissingLabel
(idPosition l) (head missings) r "record pattern"
flip RecordPattern t `liftM` mapM (checkFieldPatt r) fs
Just pat | pat == VariablePattern anonId -> do
liftM2 RecordPattern (mapM (checkFieldPatt r) fs)
(Just `liftM` checkPattern p pat)
_ -> do
report (errIllegalRecordPattern p)
return $ RecordPattern fs t
else if t == Just (VariablePattern anonId)
then liftM2 RecordPattern
(mapM (checkFieldPatt r) fs)
(Just `liftM` checkPattern p (fromJust t))
else do report (errIllegalRecordPattern p)
return $ RecordPattern fs t
where ls' = map fieldLabel fs
duplicate = findDouble ls'
missings = ls \\ ls'
[] -> report (errUndefinedLabel l) >> return (RecordPattern fs t)
[_] -> report (errNotALabel l) >> return (RecordPattern fs t)
......@@ -883,7 +897,7 @@ checkFieldExpr r (Field p l e) = do
-- ---------------------------------------------------------------------------
constrs :: Decl -> [Ident]
constrs (DataDecl _ _ _ cs ) = map constr cs
constrs (DataDecl _ _ _ cs) = map constr cs
where constr (ConstrDecl _ _ c _) = c
constr (ConOpDecl _ _ _ op _) = op
constrs (NewtypeDecl _ _ _ (NewConstrDecl _ _ c _)) = [c]
......
-- record declarations
data R1 = R1 { f11, f13 :: Int, f12 :: Bool }
data R2 = R2 { f21 :: String, f22 :: R2 }
newtype R3 = R3 { f31 :: Char }
-- record constructions
r1 :: R1
r1 = R1 { f11 = 42, f12 = True, f13 = 4 }
r2 :: R2
r2 = R2 { f21 = "hello", f22 = r2 }
r3 = R3 'c'
-- record selection
answer :: Int
answer = f11 r1
innerRecord :: R2
innerRecord = f22 r2
c :: Char
c = f31 r3
-- record update
r1' :: R1
r1' = R1 { f12 = False }
r2' :: R2
r2' = R2 { f21 = "bye" }
-- pattern matching on records
isAnswer :: R1 -> Bool
isAnswer (R1 { f11 = 42, f12 = b }) = b
firstLetter :: R2 -> Char
firstLetter (R2 { f21 = (c:cs) }) = c
firstLetter _ = 'f'
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment