diff options
| author | John J. Camilleri <john@digitalgrammars.com> | 2021-07-07 09:40:41 +0200 |
|---|---|---|
| committer | John J. Camilleri <john@digitalgrammars.com> | 2021-07-07 09:40:41 +0200 |
| commit | f2e52d6f2c2bc90febceebdea0268b40ea37476c (patch) | |
| tree | 710619761319d65c5d997ec008f57f9253eae5dd /src/compiler/GF/Compile | |
| parent | a2b23d5897b4c04b50cd222ce8f215e45a3b6e40 (diff) | |
Replace tabs for whitespace in source code
Diffstat (limited to 'src/compiler/GF/Compile')
| -rw-r--r-- | src/compiler/GF/Compile/CFGtoPGF.hs | 12 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/CheckGrammar.hs | 4 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Rename.hs | 26 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/TypeCheck/Abstract.hs | 16 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/TypeCheck/Concrete.hs | 1 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs | 16 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/TypeCheck/TC.hs | 88 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Update.hs | 66 |
8 files changed, 114 insertions, 115 deletions
diff --git a/src/compiler/GF/Compile/CFGtoPGF.hs b/src/compiler/GF/Compile/CFGtoPGF.hs index f9ab8afcf..59448ce97 100644 --- a/src/compiler/GF/Compile/CFGtoPGF.hs +++ b/src/compiler/GF/Compile/CFGtoPGF.hs @@ -18,7 +18,7 @@ import Data.List -------------------------- cf2pgf :: FilePath -> ParamCFG -> PGF -cf2pgf fpath cf = +cf2pgf fpath cf = let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf)) in updateProductionIndices pgf where @@ -33,7 +33,7 @@ cf2abstr cfg = Abstr aflags afuns acats acats = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0)) | (cat,rules) <- (Map.toList . Map.fromListWith (++)) - [(cat2id cat, catRules cfg cat) | + [(cat2id cat, catRules cfg cat) | cat <- allCats' cfg]] afuns = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0)) | rule <- allRules cfg] @@ -52,7 +52,7 @@ cf2concr cfg = Concr Map.empty Map.empty cats = allCats' cfg rules = allRules cfg - sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] : + sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] : map mkSequence rules) sequences = listArray (0,Set.size sequences0-1) (Set.toList sequences0) @@ -102,7 +102,7 @@ cf2concr cfg = Concr Map.empty Map.empty mkLinDefRef (cat,_) = (cat2fid cat 0,[0]) - + addProd prods (fid,prod) = case IntMap.lookup fid prods of Just set -> IntMap.insert fid (Set.insert prod set) prods @@ -130,5 +130,5 @@ cf2concr cfg = Concr Map.empty Map.empty mkRuleName rule = case ruleName rule of - CFObj n _ -> n - _ -> wildCId + CFObj n _ -> n + _ -> wildCId diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 71bce96c4..7f053f85c 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -175,7 +175,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do checkTyp gr typ case md of Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $ - checkDef gr (m,c) typ eq) eqs + checkDef gr (m,c) typ eq) eqs Nothing -> return () return (AbsFun (Just (L loc typ)) ma md moper) @@ -316,7 +316,7 @@ linTypeOfType cnc m typ = do mkLinArg (i,(n,mc@(m,cat))) = do val <- lookLin mc let vars = mkRecType varLabel $ replicate n typeStr - symb = argIdent n cat i + symb = argIdent n cat i rec <- if n==0 then return val else errIn (render ("extending" $$ nest 2 vars $$ diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index c7ea56b45..41b2cdc67 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/05/30 18:39:44 $ +-- > CVS $Date: 2005/05/30 18:39:44 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.19 $ -- @@ -23,9 +23,9 @@ ----------------------------------------------------------------------------- module GF.Compile.Rename ( - renameSourceTerm, - renameModule - ) where + renameSourceTerm, + renameModule + ) where import GF.Infra.Ident import GF.Infra.CheckM @@ -68,7 +68,7 @@ renameIdentTerm env = accumulateError (renameIdentTerm' env) -- Fails immediately on error, makes it possible to try other possibilities renameIdentTerm' :: Status -> Term -> Check Term -renameIdentTerm' env@(act,imps) t0 = +renameIdentTerm' env@(act,imps) t0 = case t0 of Vr c -> ident predefAbs c Cn c -> ident (\_ s -> checkError s) c @@ -85,8 +85,8 @@ renameIdentTerm' env@(act,imps) t0 = _ -> return t0 where opens = [st | (OSimple _,st) <- imps] - qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ - [(m, st) | (OQualif _ m, st) <- imps] ++ + qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ + [(m, st) | (OQualif _ m, st) <- imps] ++ [(m, st) | (OSimple m, st) <- imps] -- qualif is always possible -- this facility is mainly for BWC with GF1: you need not import PredefAbs @@ -94,7 +94,7 @@ renameIdentTerm' env@(act,imps) t0 = | isPredefCat c = return (Q (cPredefAbs,c)) | otherwise = checkError s - ident alt c = + ident alt c = case Map.lookup c act of Just f -> return (f c) _ -> case mapMaybe (Map.lookup c) opens of @@ -157,7 +157,7 @@ modInfo2status (o,mo) = (o,tree2status o (jments mo)) self2status :: ModuleName -> ModuleInfo -> StatusMap self2status c m = Map.mapWithKey (info2status (Just c)) (jments m) - + renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info renameInfo cwd status (m,mi) i info = case info of @@ -208,7 +208,7 @@ renameTerm env vars = ren vars where Abs b x t -> liftM (Abs b x) (ren (x:vs) t) Prod bt x a b -> liftM2 (Prod bt x) (ren vs a) (ren (x:vs) b) Typed a b -> liftM2 Typed (ren vs a) (ren vs b) - Vr x + Vr x | elem x vs -> return trm | otherwise -> renid trm Cn _ -> renid trm @@ -219,7 +219,7 @@ renameTerm env vars = ren vars where i' <- case i of TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source _ -> return i - liftM (T i') $ mapM (renCase vs) cs + liftM (T i') $ mapM (renCase vs) cs Let (x,(m,a)) b -> do m' <- case m of @@ -229,7 +229,7 @@ renameTerm env vars = ren vars where b' <- ren (x:vs) b return $ Let (x,(m',a')) b' - P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either + P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either -- record projection from variable or constant $r$ or qualified expression with module $r$ | elem r vs -> return trm -- try var proj first .. | otherwise -> checks [ renid' (Q (MN r,label2ident l)) -- .. and qualified expression second. @@ -331,7 +331,7 @@ renamePattern env patt = renameContext :: Status -> Context -> Check Context renameContext b = renc [] where renc vs cont = case cont of - (bt,x,t) : xts + (bt,x,t) : xts | isWildIdent x -> do t' <- ren vs t xts' <- renc vs xts diff --git a/src/compiler/GF/Compile/TypeCheck/Abstract.hs b/src/compiler/GF/Compile/TypeCheck/Abstract.hs index 196e1a646..c76660259 100644 --- a/src/compiler/GF/Compile/TypeCheck/Abstract.hs +++ b/src/compiler/GF/Compile/TypeCheck/Abstract.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/15 16:22:02 $ +-- > CVS $Date: 2005/09/15 16:22:02 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.16 $ -- @@ -13,11 +13,11 @@ ----------------------------------------------------------------------------- module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly. - checkContext, - checkTyp, - checkDef, - checkConstrs, - ) where + checkContext, + checkTyp, + checkDef, + checkConstrs, + ) where import GF.Data.Operations @@ -33,8 +33,8 @@ import GF.Text.Pretty --import Control.Monad (foldM, liftM, liftM2) -- | invariant way of creating TCEnv from context -initTCEnv gamma = - (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) +initTCEnv gamma = + (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) -- interface to TC type checker diff --git a/src/compiler/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/GF/Compile/TypeCheck/Concrete.hs index 380970405..e9420290a 100644 --- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs +++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs @@ -69,7 +69,6 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t lockRecType c t' ---- locking to be removed AR 20/6/2009 _ | ty == typeTok -> return typeStr - _ | isPredefConstant ty -> return ty _ -> composOp (comp g) ty diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs index c32afa7a5..d85af5361 100644 --- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs @@ -396,7 +396,7 @@ tcRecTypeFields ge scope ((l,ty):rs) mb_ty = do return ((l,ty):rs,mb_ty) -- | Invariant: if the third argument is (Just rho), --- then rho is in weak-prenex form +-- then rho is in weak-prenex form instSigma :: GlobalEnv -> Scope -> Term -> Sigma -> Maybe Rho -> TcM (Term, Rho) instSigma ge scope t ty1 Nothing = return (t,ty1) -- INST1 instSigma ge scope t ty1 (Just ty2) = do -- INST2 @@ -631,8 +631,8 @@ allBinders = [ identS [x] | x <- ['a'..'z'] ] ++ type Scope = [(Ident,Value)] type Sigma = Value -type Rho = Value -- No top-level ForAll -type Tau = Value -- No ForAlls anywhere +type Rho = Value -- No top-level ForAll +type Tau = Value -- No ForAlls anywhere data MetaValue = Unbound Scope Sigma @@ -724,8 +724,8 @@ getMetaVars loc sc_tys = do go (Vr tv) acc = acc go (App x y) acc = go x (go y acc) go (Meta i) acc - | i `elem` acc = acc - | otherwise = i : acc + | i `elem` acc = acc + | otherwise = i : acc go (Q _) acc = acc go (QC _) acc = acc go (Sort _) acc = acc @@ -742,9 +742,9 @@ getFreeVars loc sc_tys = do return (foldr (go []) [] tys) where go bound (Vr tv) acc - | tv `elem` bound = acc - | tv `elem` acc = acc - | otherwise = tv : acc + | tv `elem` bound = acc + | tv `elem` acc = acc + | otherwise = tv : acc go bound (App x y) acc = go bound x (go bound y acc) go bound (Meta _) acc = acc go bound (Q _) acc = acc diff --git a/src/compiler/GF/Compile/TypeCheck/TC.hs b/src/compiler/GF/Compile/TypeCheck/TC.hs index abcb24617..c0df83394 100644 --- a/src/compiler/GF/Compile/TypeCheck/TC.hs +++ b/src/compiler/GF/Compile/TypeCheck/TC.hs @@ -5,21 +5,22 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/10/02 20:50:19 $ +-- > CVS $Date: 2005/10/02 20:50:19 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.11 $ -- -- Thierry Coquand's type checking algorithm that creates a trace ----------------------------------------------------------------------------- -module GF.Compile.TypeCheck.TC (AExp(..), - Theory, - checkExp, - inferExp, - checkBranch, - eqVal, - whnf - ) where +module GF.Compile.TypeCheck.TC ( + AExp(..), + Theory, + checkExp, + inferExp, + checkBranch, + eqVal, + whnf + ) where import GF.Data.Operations import GF.Grammar @@ -31,17 +32,17 @@ import Data.Maybe import GF.Text.Pretty data AExp = - AVr Ident Val + AVr Ident Val | ACn QIdent Val - | AType - | AInt Int + | AType + | AInt Int | AFloat Double | AStr String | AMeta MetaId Val | ALet (Ident,(Val,AExp)) AExp - | AApp AExp AExp Val - | AAbs Ident Val AExp - | AProd Ident AExp AExp + | AApp AExp AExp Val + | AAbs Ident Val AExp + | AProd Ident AExp AExp -- -- | AEqs [([Exp],AExp)] --- not used | ARecType [ALabelling] | AR [AAssign] @@ -50,7 +51,7 @@ data AExp = | AData Val deriving (Eq,Show) -type ALabelling = (Label, AExp) +type ALabelling = (Label, AExp) type AAssign = (Label, (Val, AExp)) type Theory = QIdent -> Err Val @@ -71,7 +72,7 @@ whnf :: Val -> Err Val whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug case v of VApp u w -> do - u' <- whnf u + u' <- whnf u w' <- whnf w app u' w' VClos env e -> eval env e @@ -81,9 +82,9 @@ app :: Val -> Val -> Err Val app u v = case u of VClos env (Abs _ x e) -> eval ((x,v):env) e _ -> return $ VApp u v - + eval :: Env -> Term -> Err Val -eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ +eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ case e of Vr x -> lookupVar env x Q c -> return $ VCn c @@ -95,23 +96,23 @@ eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ _ -> return $ VClos env e eqVal :: Int -> Val -> Val -> Err [(Val,Val)] -eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $ +eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $ do w1 <- whnf u1 - w2 <- whnf u2 + w2 <- whnf u2 let v = VGen k case (w1,w2) of (VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2) (VClos env1 (Abs _ x1 e1), VClos env2 (Abs _ x2 e2)) -> eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2) (VClos env1 (Prod _ x1 a1 e1), VClos env2 (Prod _ x2 a2 e2)) -> - liftM2 (++) + liftM2 (++) (eqVal k (VClos env1 a1) (VClos env2 a2)) (eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)) (VGen i _, VGen j _) -> return [(w1,w2) | i /= j] - (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j] + (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j] --- thus ignore qualifications; valid because inheritance cannot - --- be qualified. Simplifies annotation. AR 17/3/2005 + --- be qualified. Simplifies annotation. AR 17/3/2005 _ -> return [(w1,w2) | w1 /= w2] -- invariant: constraints are in whnf @@ -127,10 +128,10 @@ checkExp th tenv@(k,rho,gamma) e ty = do Abs _ x t -> case typ of VClos env (Prod _ y a b) -> do - a' <- whnf $ VClos env a --- - (t',cs) <- checkExp th - (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b) - return (AAbs x a' t', cs) + a' <- whnf $ VClos env a --- + (t',cs) <- checkExp th + (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b) + return (AAbs x a' t', cs) _ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ)) Let (x, (mb_typ, e1)) e2 -> do @@ -150,7 +151,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do (b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b return (AProd x a' b', csa ++ csb) - R xs -> + R xs -> case typ of VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of [] -> return () @@ -174,7 +175,7 @@ checkInferExp th tenv@(k,_,_) e typ = do (e',w,cs1) <- inferExp th tenv e cs2 <- eqVal k w typ return (e',cs1 ++ cs2) - + inferExp :: Theory -> TCEnv -> Term -> Err (AExp, Val, [(Val,Val)]) inferExp th tenv@(k,rho,gamma) e = case e of Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x @@ -200,13 +201,13 @@ inferExp th tenv@(k,rho,gamma) e = case e of (e2,val2,cs2) <- inferExp th (k,rho,(x,val1):gamma) e2 return (ALet (x,(val1,e1)) e2, val2, cs1++cs2) App f t -> do - (f',w,csf) <- inferExp th tenv f + (f',w,csf) <- inferExp th tenv f typ <- whnf w case typ of VClos env (Prod _ x a b) -> do (a',csa) <- checkExp th tenv t (VClos env a) - b' <- whnf $ VClos ((x,VClos rho t):env) b - return $ (AApp f' a' b', b', csf ++ csa) + b' <- whnf $ VClos ((x,VClos rho t):env) b + return $ (AApp f' a' b', b', csf ++ csa) _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ)) _ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e)) @@ -232,9 +233,9 @@ checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do return ((lbl,(val,aexp)),cs) checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Term],AExp),[(Val,Val)]) -checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ - chB tenv' ps' ty - where +checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ + chB tenv' ps' ty + where (ps',_,rho2,k') = ps2ts k ps tenv' = (k, rho2++rho, gamma) ---- k' ? @@ -245,11 +246,11 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ typ <- whnf ty case typ of VClos env (Prod _ y a b) -> do - a' <- whnf $ VClos env a + a' <- whnf $ VClos env a (p', sigma, binds, cs1) <- checkP tenv p y a' let tenv' = (length binds, sigma ++ rho, binds ++ gamma) ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b) - return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt + return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt _ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ)) [] -> do (e,cs) <- checkExp th tenv t ty @@ -259,15 +260,15 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]] return (VClos sigma t, sigma, delta, cs) - ps2ts k = foldr p2t ([],0,[],k) + ps2ts k = foldr p2t ([],0,[],k) p2t p (ps,i,g,k) = case p of - PW -> (Meta i : ps, i+1,g,k) + PW -> (Meta i : ps, i+1,g,k) PV x -> (Vr x : ps, i, upd x k g,k+1) PAs x p -> p2t p (ps,i,g,k) PString s -> (K s : ps, i, g, k) PInt n -> (EInt n : ps, i, g, k) PFloat n -> (EFloat n : ps, i, g, k) - PP c xs -> (mkApp (Q c) xss : ps, j, g',k') + PP c xs -> (mkApp (Q c) xss : ps, j, g',k') where (xss,j,g',k') = foldr p2t ([],i,g,k) xs PImplArg p -> p2t p (ps,i,g,k) PTilde t -> (t : ps, i, g, k) @@ -307,8 +308,8 @@ checkPatt th tenv exp val = do case typ of VClos env (Prod _ x a b) -> do (a',_,csa) <- checkExpP tenv t (VClos env a) - b' <- whnf $ VClos ((x,VClos rho t):env) b - return $ (AApp f' a' b', b', csf ++ csa) + b' <- whnf $ VClos ((x,VClos rho t):env) b + return $ (AApp f' a' b', b', csf ++ csa) _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ)) _ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp)) @@ -321,4 +322,3 @@ mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)]) mkAnnot a ti = do (v,cs) <- ti return (a v, v, cs) - diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 4399405b8..7bbe1d8dc 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/05/30 18:39:44 $ +-- > CVS $Date: 2005/05/30 18:39:44 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.8 $ -- @@ -34,14 +34,14 @@ buildAnyTree :: Fail.MonadFail m => ModuleName -> [(Ident,Info)] -> m (Map.Map I buildAnyTree m = go Map.empty where go map [] = return map - go map ((c,j):is) = do + go map ((c,j):is) = case Map.lookup c map of Just i -> case unifyAnyInfo m i j of - Ok k -> go (Map.insert c k map) is - Bad _ -> fail $ render ("conflicting information in module"<+>m $$ - nest 4 (ppJudgement Qualified (c,i)) $$ - "and" $+$ - nest 4 (ppJudgement Qualified (c,j))) + Ok k -> go (Map.insert c k map) is + Bad _ -> fail $ render ("conflicting information in module"<+>m $$ + nest 4 (ppJudgement Qualified (c,i)) $$ + "and" $+$ + nest 4 (ppJudgement Qualified (c,j))) Nothing -> go (Map.insert c j map) is extendModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule @@ -51,14 +51,14 @@ extendModule cwd gr (name,m) ---- Should be replaced by real control. AR 4/2/2005 | mstatus m == MSIncomplete && isModCnc m = return (name,m) | otherwise = checkInModule cwd m NoLoc empty $ do - m' <- foldM extOne m (mextend m) + m' <- foldM extOne m (mextend m) return (name,m') where extOne mo (n,cond) = do m0 <- lookupModule gr n -- test that the module types match, and find out if the old is complete - unless (sameMType (mtype m) (mtype mo)) + unless (sameMType (mtype m) (mtype mo)) (checkError ("illegal extension type to module" <+> name)) let isCompl = isCompleteModule m0 @@ -67,7 +67,7 @@ extendModule cwd gr (name,m) js1 <- extendMod gr isCompl ((n,m0), isInherited cond) name (jments mo) -- if incomplete, throw away extension information - return $ + return $ if isCompl then mo {jments = js1} else mo {mextend= filter ((/=n) . fst) (mextend mo) @@ -75,7 +75,7 @@ extendModule cwd gr (name,m) ,jments = js1 } --- | rebuilding instance + interface, and "with" modules, prior to renaming. +-- | rebuilding instance + interface, and "with" modules, prior to renaming. -- AR 24/10/2003 rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) = @@ -88,8 +88,8 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js -- add the information given in interface into an instance module Nothing -> do - unless (null is || mstatus mi == MSIncomplete) - (checkError ("module" <+> i <+> + unless (null is || mstatus mi == MSIncomplete) + (checkError ("module" <+> i <+> "has open interfaces and must therefore be declared incomplete")) case mt of MTInstance (i0,mincl) -> do @@ -113,7 +113,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js let stat' = if all (flip elem infs) is then MSComplete else MSIncomplete - unless (stat' == MSComplete || stat == MSIncomplete) + unless (stat' == MSComplete || stat == MSIncomplete) (checkError ("module" <+> i <+> "remains incomplete")) ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext let ops1 = nub $ @@ -141,24 +141,24 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js extendMod :: Grammar -> Bool -> (Module,Ident -> Bool) -> ModuleName -> Map.Map Ident Info -> Check (Map.Map Ident Info) -extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi) +extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi) where try new (c,i0) | not (cond c) = return new | otherwise = case Map.lookup c new of Just j -> case unifyAnyInfo name i j of - Ok k -> return $ Map.insert c k new - Bad _ -> do (base,j) <- case j of - AnyInd _ m -> lookupOrigInfo gr (m,c) - _ -> return (base,j) - (name,i) <- case i of + Ok k -> return $ Map.insert c k new + Bad _ -> do (base,j) <- case j of + AnyInd _ m -> lookupOrigInfo gr (m,c) + _ -> return (base,j) + (name,i) <- case i of AnyInd _ m -> lookupOrigInfo gr (m,c) _ -> return (name,i) - checkError ("cannot unify the information" $$ - nest 4 (ppJudgement Qualified (c,i)) $$ - "in module" <+> name <+> "with" $$ - nest 4 (ppJudgement Qualified (c,j)) $$ - "in module" <+> base) + checkError ("cannot unify the information" $$ + nest 4 (ppJudgement Qualified (c,i)) $$ + "in module" <+> name <+> "with" $$ + nest 4 (ppJudgement Qualified (c,j)) $$ + "in module" <+> base) Nothing-> if isCompl then return $ Map.insert c (indirInfo name i) new else return $ Map.insert c i new @@ -166,11 +166,11 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme i = globalizeLoc (msrc mi) i0 indirInfo :: ModuleName -> Info -> Info - indirInfo n info = AnyInd b n' where + indirInfo n info = AnyInd b n' where (b,n') = case info of ResValue _ -> (True,n) ResParam _ _ -> (True,n) - AbsFun _ _ Nothing _ -> (True,n) + AbsFun _ _ Nothing _ -> (True,n) AnyInd b k -> (b,k) _ -> (False,n) ---- canonical in Abs @@ -194,24 +194,24 @@ globalizeLoc fpath i = unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info unifyAnyInfo m i j = case (i,j) of - (AbsCat mc1, AbsCat mc2) -> + (AbsCat mc1, AbsCat mc2) -> liftM AbsCat (unifyMaybeL mc1 mc2) - (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) -> + (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) -> liftM4 AbsFun (unifyMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifyMaybe moper1 moper2) -- adding defs (ResParam mt1 mv1, ResParam mt2 mv2) -> liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2) - (ResValue (L l1 t1), ResValue (L l2 t2)) + (ResValue (L l1 t1), ResValue (L l2 t2)) | t1==t2 -> return (ResValue (L l1 t1)) | otherwise -> fail "" (_, ResOverload ms t) | elem m ms -> return $ ResOverload ms t - (ResOper mt1 m1, ResOper mt2 m2) -> + (ResOper mt1 m1, ResOper mt2 m2) -> liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2) - (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) -> + (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) -> liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2) (unifyMaybe mpmcfg1 mpmcfg2) - (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) -> + (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) -> liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2) (AnyInd b1 m1, AnyInd b2 m2) -> do |
