[initial version mail@stefanwehr.de**20050518101415] { adddir ./mk adddir ./pp adddir ./tests adddir ./tests/ast adddir ./tests/ast/should_fail adddir ./tests/ast/should_pass adddir ./tests/driver adddir ./tests/kind-inference adddir ./tests/kind-inference/should_fail adddir ./tests/kind-inference/should_pass adddir ./tests/tyinfer adddir ./tests/tyinfer/should_fail adddir ./tests/tyinfer/should_pass adddir ./tests/well-formed adddir ./tests/well-formed/should_fail addfile ./AUTHORS hunk ./AUTHORS 1 +Don Stewart - http://www.cse.unsw.edu.au/~dons +Gabriele Keller - keller@cse.unsw.edu.au +Stefan Wehr - http://www.stefanwehr.de addfile ./AbstractSyntax.hs hunk ./AbstractSyntax.hs 1 +{-# OPTIONS_GHC -cpp -fglasgow-exts -no-recomp #-} +#define ABSTRACT_SYNTAX 1 +#include "ParseSyntax.hs" addfile ./Builtins.hs hunk ./Builtins.hs 1 - +{-# OPTIONS_GHC -fglasgow-exts #-} +-- for deriving Data and Typeable + +module Builtins where + +import qualified List +import qualified Data.Generics as Gen +import Error +import Pretty + +-- +-- builtin operations +-- + +data Op = IntAddOp + | IntSubOp + | IntMulOp + | IntQuotOp + | IntRemOp + | IntNegOp + | IntGtOp + | IntGeOp + | IntLtOp + | IntLeOp + | IntEqOp + | IntNeOp + deriving (Show, Ord, Eq, Read, Gen.Data, Gen.Typeable) + +instance Pretty Op where ppr = text . show + +data PrimInfo = PrimInfo String -- name + Op + OpSpec + Int -- arity + +primsMap :: [PrimInfo] +primsMap = + [ PrimInfo "+" IntAddOp (LeftAssoc, 7) 2 + , PrimInfo "-" IntSubOp (LeftAssoc, 7) 2 + -- IntNegOp must be AFTER IntSubOp + , PrimInfo "-" IntNegOp (NoAssoc, maxPrec) 1 + , PrimInfo "*" IntMulOp (LeftAssoc, 8) 2 + , PrimInfo "/" IntQuotOp (LeftAssoc, 8) 2 + , PrimInfo "%" IntRemOp (LeftAssoc, 8) 2 + , PrimInfo ">" IntGtOp (LeftAssoc, 6) 2 + , PrimInfo ">=" IntGeOp (LeftAssoc, 6) 2 + , PrimInfo "<" IntLtOp (LeftAssoc, 6) 2 + , PrimInfo "<=" IntLeOp (LeftAssoc, 6) 2 + , PrimInfo "==" IntEqOp (LeftAssoc, 6) 2 + , PrimInfo "/=" IntNeOp (LeftAssoc, 6) 2 + ] + +strToPrimOp :: String -> Maybe Op +strToPrimOp s = + case List.find f primsMap of + Just (PrimInfo _ op _ _) -> Just op + _ -> Nothing + where f (PrimInfo s' _ _ _) | s == s' = True + | otherwise = False + +lookupPrim :: Op -> PrimInfo +lookupPrim op = + case List.find f primsMap of + Just i -> i + Nothing -> panic ("no info for primOp " ++ show op) + where f (PrimInfo _ op' _ _) | op == op' = True + | otherwise = False + +isBinPrimOp :: Op -> Bool +isBinPrimOp op = arityOfPrimOp op == 2 + +arityOfPrimOp op = + case lookupPrim op of + (PrimInfo _ _ _ a) -> a + +specOfPrimOp :: Op -> OpSpec +specOfPrimOp op = + case lookupPrim op of + (PrimInfo _ _ spec _) -> spec + +primOpToStr :: Op -> String +primOpToStr IntNegOp = "-" +primOpToStr op = + case lookupPrim op of + (PrimInfo s _ _ _) -> s + +{- +typeOfPrimOp:: Op -> Type +typeOfPrimOp IntAddOp = binIntTy +typeOfPrimOp IntSubOp = binIntTy +typeOfPrimOp IntMulOp = binIntTy +typeOfPrimOp IntQuotOp = binIntTy +typeOfPrimOp IntRemOp = binIntTy +typeOfPrimOp IntNegOp = mkFunTy [intTyCon, intTyCon] +typeOfPrimOp IntGtOp = binCmpTy +typeOfPrimOp IntGeOp = binCmpTy +typeOfPrimOp IntLtOp = binCmpTy +typeOfPrimOp IntLeOp = binCmpTy +typeOfPrimOp IntEqOp = binCmpTy +typeOfPrimOp IntNeOp = binCmpTy + + +-- +-- builtin type constructors +-- + +funTyCon = TyConstruct (mkIdFromString "->") +intTyCon = TyConstruct (mkIdFromString "Int") +boolTyCon = TyConstruct (mkIdFromString "Bool") +starTyCon = TyConstruct (mkIdFromString "(,)") +unitTyCon = TyConstruct (mkIdFromString "()") + +builtinTypeConstructors = + [funTyCon, intTyCon, boolTyCon, starTyCon, unitTyCon] + +binIntTy, binCmpTy :: Type +binIntTy = mkFunTy [intTyCon, intTyCon, intTyCon] +binCmpTy = mkFunTy [intTyCon, intTyCon, boolTyCon] + +mkFunTy :: [Type] -> Type +mkFunTy (t1:t2:[]) = TyApp (TyApp funTyCon t1) t2 +mkFunTy (t1:t2:ts) = TyApp (TyApp funTyCon t1) (mkFunTy (t2:ts)) +mkFunTy _ = panic "cannot make function type for less then 2 types" +-} + + +-- +-- Names and arities for builtin data constructors, +-- names for builtin types +-- + +unitDataConstructor = ("()", 0::Int) +pairDataConstructor = ("Pair", 2::Int) +falseDataConstructor = ("False", 0::Int) +trueDataConstructor = ("True", 0::Int) + +dataConstructors = [unitDataConstructor, pairDataConstructor, + trueDataConstructor, falseDataConstructor] + + +funTypeConstructor = "->" +pairTypeConstructor = "(,)" +intTypeConstructor = "Int" +boolTypeConstructor = "Bool" +unitTypeConstructor = "Unit" + +typeConstructors = [funTypeConstructor, pairTypeConstructor, + intTypeConstructor, boolTypeConstructor, + unitTypeConstructor] + + addfile ./DependAnalysis.hs hunk ./DependAnalysis.hs 1 +module DependAnalysis where + +import Data.Graph + +getBindGroups :: Ord name => + [node] -- List of nodes + -> (node -> name) -- Function to convert nodes to a unique name + -> (node -> [name])-- Function to return dependencies of this node + -> [[node]] -- Bindgroups +getBindGroups ns getName getDeps = + map flattenSCC (stronglyConnComp graph) + where graph = [ (node, getName node, getDeps node) | node <- ns ] + addfile ./Entailment.hs hunk ./Entailment.hs 1 +module Entailment where + addfile ./Error.hs hunk ./Error.hs 1 +{-# OPTIONS -cpp #-} +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- + +module Error ( + + phasefail_, panic_, + pprPhaseFail_, pprPanic_, + PException(..), showWithoutLocation + + ) where + +import Pretty + +import Data.Dynamic + +import Control.Exception as E ( throwDyn ) +import System.Environment ( getProgName ) +import System.IO.Unsafe ( unsafePerformIO ) + +-- +-- program exceptions +-- + +type Location = (String, Int) + +data PException + = PhaseFailed Location String -- location, message + | Panic Location String -- the `impossible' happened + deriving Eq + +instance Show PException where + showsPrec _ e = showString progName . showString ": " . showPException e + +showPException :: PException -> ShowS +showPException (PhaseFailed (fname, lineno) msg) + = foldr1 (.) (map showString [ fname, ":", show lineno, ": ", msg]) + +showPException (Panic (fname, lineno) s) + = showString $ fname ++ ":" ++ show lineno ++ ": panic!:\n\t" ++ s ++ "\n\n" + +showWithoutLocation :: PException -> String +showWithoutLocation (PhaseFailed _ msg) = msg +showWithoutLocation (Panic _ msg) = msg + +pExceptionTc :: TyCon +pExceptionTc = mkTyCon "PException" +{-# NOINLINE pExceptionTc #-} + +instance Typeable PException where +#if __GLASGOW_HASKELL__ >= 603 + typeOf _ = mkTyConApp pExceptionTc [] +#else + typeOf _ = mkAppTy pExceptionTc [] +#endif + +-- +-- panics and general failures +-- +panic_ :: Location -> String -> a +panic_ l x = E.throwDyn (Panic l x) + +phasefail_ :: Location -> String -> a +phasefail_ l x = E.throwDyn (PhaseFailed l x) + +pprPanic_ :: Pretty a => Location -> String -> a -> b +pprPanic_ loc msg code = + panic_ loc $ msg ++ "\nIn the expression:\n" ++ (show (nest 8 (ppr code))) + +pprPhaseFail_ :: Pretty a => Location -> String -> a -> b +pprPhaseFail_ loc msg code = + phasefail_ loc $ "\n\t" ++ msg ++ + "\nIn the expression:\n" ++ (show (nest 8 (ppr code))) + +------------------------------------------------------------------------ + +progName :: String +progName = unsafePerformIO (getProgName) +{-# NOINLINE progName #-} + + addfile ./IdMap.hs hunk ./IdMap.hs 1 +module IdMap where + +import qualified Map +import AbstractSyntax +import Pretty + +data IdMap a b c d e f g = IdMap { typeVarMap :: Map.Map TypeVarId a, + typeMap :: Map.Map TypeId b, + valMap :: Map.Map ValId c, + dataMap :: Map.Map DataId d, + classMap :: Map.Map ClassId e, + assocTypeMap :: Map.Map AssocTypeId f, + methodMap :: Map.Map MethodId g } + + +emptyIdMap = IdMap e e e e e e e + where e = Map.empty + +elemsIdMap m = + (Map.elems (typeVarMap m), Map.elems (typeMap m), Map.elems (valMap m), + Map.elems (dataMap m), Map.elems (classMap m), Map.elems (assocTypeMap m), + Map.elems (methodMap m)) + +mapIdMap :: ((a -> a'), (b -> b'), (c -> c'), (d -> d'), (e -> e'), + (f -> f'), (g -> g')) + -> IdMap a b c d e f g + -> IdMap a' b' c' d' e' f' g' +mapIdMap (a, b, c, d, e, f, g) m = + IdMap { typeVarMap = Map.map a (typeVarMap m), + typeMap = Map.map b (typeMap m), + valMap = Map.map c (valMap m), + dataMap = Map.map d (dataMap m), + classMap = Map.map e (classMap m), + assocTypeMap = Map.map f (assocTypeMap m), + methodMap = Map.map g (methodMap m) } + +insertTypeVar k v m = m { typeVarMap = Map.insert k v (typeVarMap m) } +insertTypeVars kvs m = m { typeVarMap = foldr (\ (k,v) m -> Map.insert k v m) + (typeVarMap m) kvs } + +insertType k v m = m { typeMap = Map.insert k v (typeMap m) } +insertVal k v m = m { valMap = Map.insert k v (valMap m) } +insertData k v m = m { dataMap = Map.insert k v (dataMap m) } +insertClass k v m = m { classMap = Map.insert k v (classMap m) } +insertAssocType k v m = m { assocTypeMap = Map.insert k v (assocTypeMap m) } +insertMethod k v m = m { methodMap = Map.insert k v (methodMap m) } + +saveLookup k m = + case Map.lookup k m of + Just v -> return v + Nothing -> fail ("IdMap.saveLookup failed. key: " ++ show k) + +lookupTypeVar k m = saveLookup k (typeVarMap m) +lookupType k m = saveLookup k (typeMap m) +lookupVal k m = saveLookup k (valMap m) +lookupData k m = saveLookup k (dataMap m) +lookupClass k m = saveLookup k (classMap m) +lookupAssocType k m = saveLookup k (assocTypeMap m) +lookupMethod k m = saveLookup k (methodMap m) + addfile ./KindInference.hs hunk ./KindInference.hs 1 +{-# OPTIONS_GHC -fglasgow-exts #-} +{------------------------------------------------------------------------------- + + Copyright: The Hatchet Team (see file Contributors) + + Module: KindInference + + Description: Kind inference of data and class declarations. + Based very closely on type inference. + + Primary Authors: Bernie Pope + + Notes: See the file License for license information + +-------------------------------------------------------------------------------} + +module KindInference where + +import qualified Control.Monad.State as StateMonad +import qualified Map +import qualified Data.Generics as Gen +import qualified List + +import qualified DependAnalysis +import qualified UniqIdents +import Builtins +import AbstractSyntax +import Error +import Pretty +import Symtab +import IdMap +import Substitution +import Kinds + +-------------------------------------------------------------------------------- + +type KVar = Int + +-- is converted to the "real" Kind after kind inference +data Kind' = Kfun Kind' Kind' + | KVar KVar + | Star + deriving (Eq,Show) + +instance Pretty Kind' where + ppr = text . show + +type KindEnv = IdMap Kind' Kind' Kind' Kind' Kind' Kind' Kind' + +type KindSubst = Subst KVar Kind' + + +class Substitution KVar Kind' a => Kinds a where + vars :: a -> [KVar] + +instance Substitution KVar Kind' Kind' where + applySubst s Star = Star + applySubst s (KVar kindvar) + = case substLookup kindvar s of + Just k -> k + Nothing -> KVar kindvar + applySubst s (kind1 `Kfun` kind2) + = (applySubst s kind1) `Kfun` (applySubst s kind2) + +instance Kinds Kind' where + vars Star = [] + vars (KVar kindvar) = [kindvar] + vars (kind1 `Kfun` kind2) = vars kind1 ++ vars kind2 + +instance Kinds a => Kinds [a] where + vars = List.nub . concatMap vars + +instance Substitution a b c => Substitution a b (d, c) where + applySubst s (x, y) = (x, applySubst s y) + +instance Kinds a => Kinds (b, a) where + vars (x, y) = vars y + + +-------------------------------------------------------------------------------- + +-- unification + + +-- mgu :: Kind -> Kind -> Maybe Subst + +-- can return either a substitution or a string +mgu :: Kind' -> Kind' -> Either KindSubst String +mgu Star Star = Left nullSubst +mgu (k1 `Kfun` k2) (k3 `Kfun` k4) + = case mgu k1 k3 of + Right errorMsg + -> Right errorMsg + Left s1 + -> case mgu (applySubst s1 k2) (applySubst s1 k4) of + Right errorMsg -> Right errorMsg + Left s2 -> Left $ s2 `composeSubst` s1 + +mgu (KVar u) k = varBind u k +mgu k (KVar u) = varBind u k +mgu k1 k2 = Right ("attempt to unify these two kinds: " ++ show k1 ++ + ", " ++ show k2) + +varBind :: KVar -> Kind' -> Either KindSubst String +varBind u k + | k == (KVar u) = Left nullSubst + | u `elem` vars k = Right ("occurs check failed in kind inference: " ++ + show u ++ ", " ++ show k) + | otherwise = Left (u +-> k) + + +-------------------------------------------------------------------------------- + +-- The kind inference monad + +type KI = StateMonad.StateT KIState ST + +data KIState = KIState + { env :: KindEnv, -- the environment of kind assumptions + subst :: KindSubst, -- the current substitution + varnum :: Int -- to keep our supply fresh + } + +initState = KIState { env = emptyIdMap, subst = nullSubst, varnum = 0 } + +liftST x = StateMonad.lift x + +{- +debug s = liftST $ liftIO $ putStrLn s +debugST s = liftIO $ putStrLn s +-} +debug s = return () +debugST s = return () + +-------------------------------------------------------------------------------- + +-- useful operations in the inference monad + +runKI :: KI a -> ST a +runKI comp = StateMonad.evalStateT comp initState + +getSubst :: KI KindSubst +getSubst = StateMonad.gets subst + +getVarNum :: KI Int +getVarNum = StateMonad.gets varnum + +getEnv :: KI (KindEnv) +getEnv = StateMonad.gets env + +modifyEnv :: (KindEnv -> KindEnv) -> KI () +modifyEnv f = StateMonad.modify ( \s -> s { env = f (env s) }) + + +getEnvVars :: KI [KVar] +getEnvVars = + do env <- getEnv + let (a,b,c,d,e,f,g) = elemsIdMap env + allKinds = a ++ b ++ c ++ d ++ e ++ f ++ g + return (vars allKinds) + +-- returns the old varnum +incVarNum :: KI Int +incVarNum = + do i <- getVarNum + StateMonad.modify (\s -> s { varnum = i + 1 }) + return i + +unify :: Kind' -> Kind' -> KI () +unify k1 k2 + = do s <- getSubst + case mgu (applySubst s k1) (applySubst s k2) of + Left newSubst -> extendSubst newSubst + Right errorMsg -> phasefail errorMsg + +extendSubst :: KindSubst -> KI () +extendSubst subst = + do oldSubst <- getSubst + StateMonad.modify (\s -> s { subst = subst `composeSubst` oldSubst}) + +newKindVar :: KI Kind' +newKindVar = + do n <- incVarNum + return (KVar n) + +newKindVars :: Int -> KI [Kind'] +newKindVars n = + mapM (\_ -> newKindVar) [1..n] + +applySubstToEnv :: KindSubst -> KI () +applySubstToEnv subst = + let a = applySubst subst + in modifyEnv $ mapIdMap (a, a, a, a, a, a, a) + +-- clobber all remaining variables to stars +envVarsToStars :: KI () +envVarsToStars = + do vars <- getEnvVars + let varsToStarSubst = substFromAssocs $ map (\v -> (v, Star)) vars + applySubstToEnv varsToStarSubst + + +-------------------------------------------------------------------------------- + +-- dependency analysis + +type DepGroup = [DepGroupElem] + +data DepGroupElem = DepGroupTypeDef TypeDef + | DepGroupClassDec ClassDec + deriving (Eq) + +instance Show DepGroupElem where + show (DepGroupTypeDef td) = show (tydef_name td) + show (DepGroupClassDec cd) = show (class_name cd) + +data DepGroupName = DepGroupTypeId TypeId + | DepGroupClassId ClassId + deriving (Eq,Ord,Show) + +nameOfElem (DepGroupClassDec clazz) = DepGroupClassId (class_name clazz) +nameOfElem (DepGroupTypeDef tydef) = DepGroupTypeId (tydef_name tydef) + +isClassDec (DepGroupClassDec _) = True +isClassDec _ = False + +isTypeDef (DepGroupTypeDef _) = True +isTypeDef _ = False + +listQuery f x = Gen.everything (++) ([] `Gen.mkQ` f) x + +assocIdToDepGroupName :: AssocTypeId -> ST DepGroupName +assocIdToDepGroupName id = + do clazz <- findClassOfAssocType id + return (DepGroupClassId $ class_name clazz) + +dependencies :: DepGroupElem -> ST [DepGroupName] +dependencies (DepGroupTypeDef tydef) = + -- the dependencies of a data declaration are the type constructors + -- and the classes of the associated type synonyms used on the rhs + let usedTypeDefs = listQuery collectTycons tydef + usedAssocTysyns = listQuery collectAssocs tydef + tydefNames = map DepGroupTypeId usedTypeDefs + in do assocNames <- mapM assocIdToDepGroupName usedAssocTysyns + return (tydefNames ++ assocNames) + where collectTycons (TyConstruct id) = [id] + collectTycons _ = [] + collectAssocs (AssocType name _) = [name] + +dependencies (DepGroupClassDec cd) = + -- the dependencies of a class declaration are the classes and type + -- constructors and the classes of the associated type synonyms used + -- inside the class + let usedClasses = listQuery collectClasses cd + usedTypeDefs = listQuery collectTyIds cd + usedAssocTysyns = listQuery collectAssocs cd + classNames = map DepGroupClassId usedClasses + tydefNames = map DepGroupTypeId usedTypeDefs + in do assocNames <- mapM assocIdToDepGroupName usedAssocTysyns + return (tydefNames ++ assocNames ++ classNames) + where collectClasses (ClassConstraint id _) = [id] + collectTyIds :: TypeId -> [TypeId] + collectTyIds x = [x] + collectAssocs (AssocType name _) = [name] + +getDepGroups :: Program -> ST [DepGroup] +getDepGroups (Program typeDefs classDecs _ _) = + let elems = map DepGroupTypeDef typeDefs ++ map DepGroupClassDec classDecs + in do deps <- mapM dependencies elems + let depEnv = zip elems deps + groups = DependAnalysis.getBindGroups elems + nameOfElem (depsOfElem depEnv) + return groups + where depsOfElem env elem = + case List.lookup elem env of + Just l -> l + -- list is empty for elements without dependencies + Nothing -> panic ("no dependencies for elem " ++ show elem) + +-------------------------------------------------------------------------------- + +-- kind inference proper +-- this is what gets called from outside of this module +kindInference :: Program -> ST Program +kindInference prg@(Program typeDefs classDecs classInsts valBinds) = + do groups <- getDepGroups prg + debugST ("dependency groups: " ++ show groups) + runKI $ do --mapM insertBuiltin Builtins.typeConstructors + mapM kiGroup groups + mapM kiInst classInsts + kiAllBinds valBinds + currentSubst <- getSubst + applySubstToEnv currentSubst + envVarsToStars + correctKinds prg + where insertBuiltin s = + let id = UniqIdents.builtinTypeId s + k = kindOfBuiltin s + in modifyEnv (insertType id k) + +-- we have to rewrite the program by replacing the dummy kinds of the +-- type variables with the correct ones. +correctKinds :: Program -> KI Program +correctKinds p = + Gen.everywhereM (Gen.mkM correct) p + where + correct :: TypeVarId -> KI TypeVarId + correct id = + do env <- getEnv + case lookupTypeVar id env of + Nothing -> panic ("correcting program but no kind found for " ++ + "type variable " ++ showPpr id) + Just (KVar _) -> + panic ("correcting program but kind for " ++ + showPpr id ++ " is still a kind variable") + Just k -> do liftST $ insertKind id (translate k) + return id + translate Star = KindStar + translate (Kfun k1 k2) = KindFun (translate k1) (translate k2) + +kiGroup :: DepGroup -> KI () +kiGroup group = + let classes = map (\ (DepGroupClassDec cd) -> cd) $ filter isClassDec group + tydefs = map (\ (DepGroupTypeDef td) -> td) $ filter isTypeDef group + in do mapM kiClassHead classes + mapM kiTypeDefLhs tydefs + mapM kiClassConstraints (map class_constraints classes) + mapM kiTypeDefRhs tydefs + mapM kiTSigs (map class_tsigs classes) + mapM kiVSigs (map class_vsigs classes) + currentSubst <- getSubst + applySubstToEnv currentSubst + envVarsToStars + +kiClassHead :: ClassDec -> KI () +kiClassHead (ClassDec name arg constrs tsigs vsigs) = + do debug ("kiClassHead: " ++ show name) + varKind <- newKindVar + modifyEnv (\env -> insertClass name varKind + (insertTypeVar arg varKind env)) + +kiTypeDefLhs :: TypeDef -> KI () +kiTypeDefLhs (TypeDef name args alts) = + do argKinds <- newKindVars (length args) + let typeDefKind = foldr Kfun Star argKinds + modifyEnv (\env -> insertType name typeDefKind + (insertTypeVars (zip args argKinds) env)) + +kiClassConstraints = mapM kiClassConstraint + +kiClassConstraint :: ClassConstraint -> KI () +kiClassConstraint (ClassConstraint className (TyVar argName)) = + do env <- getEnv + classKind <- lookupClass className env + argKind <- lookupTypeVar argName env + unify classKind argKind + +kiTypeDefRhs :: TypeDef -> KI () +kiTypeDefRhs tydef = + let types = concatMap dconstr_params (tydef_alts tydef) + in do kinds <- mapM kiType types + mapM (\k -> unify k Star) kinds + return () + +kiTSigs = mapM kiTSig + +kiTSig :: TSig -> KI () +kiTSig (_, []) = panic "invalid associated type synonym declaration" +kiTSig (id, index:rest) = + do env <- getEnv + indexKind <- lookupTypeVar index env + let restKinds = take (length rest) (repeat Star) + resultKind <- newKindVar + let assocTypeKind = foldr Kfun resultKind (indexKind:restKinds) + modifyEnv (\env -> insertAssocType id assocTypeKind + (insertTypeVars (zip rest restKinds) env)) + +kiVSigs = mapM kiVSig + +kiVSig :: VSig -> KI () +kiVSig (mid, tyScheme) = kiTypeScheme tyScheme + +kiInst :: ClassInst -> KI () +kiInst ci = + do let vars = freeTypeVarsList (inst_type ci) + kinds <- newKindVars (length vars) + modifyEnv (insertTypeVars (zip vars kinds)) + argKind <- kiType (inst_type ci) + env <- getEnv + classArgKind <- lookupClass (inst_class ci) env + unify classArgKind argKind + mapM kiConstraint (inst_constraints ci) + kiAssocTypeBind (inst_typeBind ci) + kiAllBinds (inst_valBinds ci) + return () + +kiConstraint :: Constraint -> KI () +kiConstraint (CC cc) = kiClassConstraint cc +kiConstraint (EC ec) = + do kiType (TyAssoc (eqc_left ec)) + kiType (eqc_right ec) + return () + +kiAssocTypeBind :: AssocTypeBind -> KI () +kiAssocTypeBind atb = + do env <- getEnv + atKind <- lookupAssocType (assocBind_name atb) env + indexKind <- kiType (assocBind_index atb) + let params = assocBind_params atb + paramKinds <- newKindVars (length params) + modifyEnv (insertTypeVars (zip params paramKinds)) + resKind <- kiType (assocBind_def atb) + unify atKind (foldr Kfun resKind (indexKind:paramKinds)) + +kiTypeScheme :: TypeScheme -> KI () +kiTypeScheme (TypeScheme quants qtype) = + do quantKinds <- newKindVars (length quants) + modifyEnv (insertTypeVars (zip quants quantKinds)) + k <- kiQualifiedType qtype + unify k Star + return () + +kiQualifiedType :: QualifiedType -> KI Kind' +kiQualifiedType (ConstrainedType cs ty) = + do mapM kiConstraint cs + kiType ty +kiQualifiedType (UnconstrainedType ty) = kiType ty + + +kiType :: Type -> KI Kind' +kiType (TyVar id) = + do env <- getEnv + lookupTypeVar id env +kiType (TyApp t1 t2) = + do k1 <- kiType t1 + k2 <- kiType t2 + resultKind <- newKindVar + unify k1 (k2 `Kfun` resultKind) + return resultKind +kiType (TyConstruct id) = + do env <- getEnv + lookupType id env +kiType (TyAssoc at) = + do paramKinds <- mapM kiType (assoc_params at) + env <- getEnv + k <- lookupAssocType (assoc_name at) env + resultKind <- newKindVar + unify k (foldr Kfun resultKind paramKinds) + return resultKind + +kiAllBinds :: Gen.Data a => a -> KI () +kiAllBinds x = + do Gen.everywhereM (Gen.mkM kiBind) x + return () + where + kiBind :: ValBind -> KI ValBind + kiBind vbind = + do case vbind_type vbind of + Just tyScheme -> kiTypeScheme tyScheme >> return vbind + Nothing -> return vbind + +dumpKindInference :: Program -> ST Doc +dumpKindInference (Program typeDefs classes _ _) = + do l <- kindAssocs + let vars = vcat $ map printKind l + tsigs = concat $ map class_tsigs classes + tydefKinds <- mapM kindOf typeDefs + assocKinds <- mapM kindOf tsigs + let tydefs = vcat $ map printKind (zip (map tydef_name typeDefs) + tydefKinds) + assocs = vcat $ map printKind (zip (map fst tsigs) assocKinds) + return (vars $$ tydefs $$ assocs) + where printKind :: Pretty v => (v,Kind) -> Doc + printKind (v,k) = ppr v <+> text "::" <+> ppr k + +starStarStar = Kfun Star (Kfun Star Star) + +kindMap = [(funTypeConstructor, starStarStar), + (pairTypeConstructor, starStarStar), + (intTypeConstructor, Star), + (boolTypeConstructor, Star), + (unitTypeConstructor, Star)] + +kindOfBuiltin s = + case List.lookup s kindMap of + Just k -> k + Nothing -> panic ("Unknown builtin: " ++ s) + + addfile ./Kinds.hs hunk ./Kinds.hs 1 +{-# OPTIONS_GHC -fglasgow-exts #-} +module Kinds where + +import Symtab +import AbstractSyntax +import Error + +class HasKind t where + kindOf :: t -> ST Kind + +instance HasKind TypeVarId where + kindOf id = kindOfTypeVarId id + +instance HasKind TypeId where + kindOf id = + do td <- findTypeDef id + kindOf td + +instance HasKind AssocTypeId where + kindOf id = + do tsig <- findAssocTypeSig id + kindOf tsig + +instance HasKind TypeDef where + kindOf td = + do paramKinds <- mapM kindOf (tydef_params td) + return $ foldr KindFun KindStar paramKinds + +instance HasKind TSig where + kindOf (id,params) = + do paramKinds <- mapM kindOf params + return $ foldr KindFun KindStar paramKinds + +instance HasKind Type where + kindOf (TyVar id) = kindOf id + kindOf (TyApp t _) = + do k <- kindOf t + case k of + KindFun _ k' -> return k' + _ -> panic "illegal kind" + kindOf (TyConstruct id) = kindOf id + kindOf (TyAssoc at) = kindOf at + +instance HasKind AssocType where + kindOf at = + do k <- kindOf (assoc_name at) + return $ erase k (assoc_params at) + where erase k [] = k + erase (KindFun _ k) (x:xs) = erase k xs + erase _ _ = panic "illegal kind" + addfile ./LICENSE hunk ./LICENSE 1 + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. addfile ./Lexer.x hunk ./Lexer.x 1 +-- +-- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- + +-- +-- Lexical analyser for Mini Haskell +-- +-- Based on the example Haskell lexer distributed with the alex-2.0 +-- distribution, (c) Simon Marlow. +-- +-- This file is specifies the token-level aspects of the concrete syntax +-- of Mini Haskell v0.0. The remaining concrete syntax is specified by +-- the Parser. +-- +-- Points of some interests: +-- * We don't handle layout +-- +-- Design issues: +-- * we explicitly recognise /expression/ syntax, and special +-- chars, so that we can pattern match more easily in the parser. +-- The downside is that you'll have to modify the parser *and* the +-- lexer if you add new syntax. +-- + +{ + +{-# OPTIONS -fno-warn-name-shadowing #-} +{-# OPTIONS -fno-warn-missing-signatures #-} +{-# OPTIONS -fno-warn-unused-binds #-} +{-# OPTIONS -fno-warn-unused-matches #-} + +-- ^ don't want to see all the warns alex templates produce + +module Lexer ( + scan, + showPos, + Token(..), Tkn(..) + ) where + +import Error ( phasefail_ ) + +} + +%wrapper "posn" + +$whitechar = [ \t\n\r\f\v] +$special = [\(\)\,\;\[\]\`\{\}] + +$ascdigit = 0-9 +$digit = [$ascdigit] + +$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~] +$symbol = [$ascsymbol] # [$special \_\:\"\'] + +$large = [A-Z \xc0-\xd6 \xd8-\xde] +$small = [a-z \xdf-\xf6 \xf8-\xff \_] +$alpha = [$small $large] + +$graphic = [$small $large $symbol $digit $special \:\"\'] + +$octit = 0-7 +$hexit = [0-9 A-F a-f] +$idchar = [$alpha $digit \'] +$symchar = [$symbol \:] +$nl = [\n\r] + +@varid = $small $idchar* +@conid = $large $idchar* +@varsym = $symbol $symchar* +@consym = \: $symchar* + +@decimal = $digit+ +@octal = $octit+ +@hexadecimal = $hexit+ +@exponent = [eE] [\-\+] @decimal + +$cntrl = [$large \@\[\\\]\^\_] +@ascii = \^ $cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK + | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE + | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM + | SUB | ESC | FS | GS | RS | US | SP | DEL +$charesc = [abfnrtv\\\"\'\&] +@escape = \\ ($charesc | @ascii | @decimal | o @octal | x @hexadecimal) +@gap = \\ $whitechar+ \\ +@string = $graphic # [\"\\] | " " | @escape | @gap + +@reservedid = + as|case|class|data|default|deriving|do|else|hiding|if| + import|in|infix|infixl|infixr|instance|let|letrec|module|newtype| + of|qualified|then|type|where|forall + +@reservedop = + ".." | ":" | "::" | "=" | \\ | "|" | "<-" | "->" | "@" | "~" | "=>" | "-" + +@comment = "--"\-*[^$symbol]?.* +@ws = $white+ | @comment + +minhs :- + +<0> @ws ; +<0> $special { \p s -> T p (SpecialT (head s)) } +<0> @reservedid { \p s -> T p (ReservedIdT s) } +<0> @reservedop { \p s -> T p (ReservedOpT s) } +<0> @varid { \p s -> T p (VarIdT s) } +<0> @conid { \p s -> T p (ConIdT s) } +<0> @varsym { \p s -> T p (VarSymT s) } +<0> @consym { \p s -> T p (ConSymT s) } + +<0> @decimal + | 0[oO] @octal + | 0[xX] @hexadecimal { \p s -> T p (IntegerT (read s)) } + +-- <0> @decimal \. @decimal @exponent? +-- | @decimal @exponent { \p s -> T p (FloatT s) } + +-- <0> \' ($graphic # [\'\\] | " " | @escape) \' +-- { \p s -> T p (CharT (head s)) } + +-- <0> \" @string* \" { \p s -> T p (StringT s) } + +{ + +data Token = T AlexPosn Tkn + deriving (Show) + +data Tkn + = VarIdT String + | ConIdT String + | VarSymT String + | ConSymT String +-- | QVarIdT String +-- | QConIdT String +-- | QVarSymT String +-- | QConSymT String + | IntegerT Integer +-- | FloatT String +-- | CharT Char +-- | StringT String + | SpecialT Char + | ReservedOpT String + | ReservedIdT String + | EOFT + deriving (Show) + +showPos :: AlexPosn -> String +showPos (AlexPn _ l c) = "line " ++ show l ++ ":" ++ show c + +scan :: String -> [Token] +scan str = go (alexStartPos,'\n',str) + where + go inp@(pos,_,str) = case alexScan inp 0 of + AlexEOF -> [] + AlexError (p,_,s) -> + phasefail "Lexer" $ showPos p ++ " `" ++ [head s] ++ "'" + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act pos (take len str) : go inp' + +} addfile ./Main.hs hunk ./Main.hs 1 +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- + +-- +-- The main driver for the MinHS compiler +-- + +module Main ( main ) where + +-- import Syntax +import Lexer +import Parser +import SyntaxTransformation +import TyInfer +import TyCheck +--import Eval +import qualified WellFormedProgram as WFP +import Error +import Pretty +import Symtab +import KindInference + +import Control.Exception ( catchDyn, evaluate ) +import Control.Monad ( when ) + +import System.IO ( hFlush, stdin, stdout, stderr, hPutStrLn, + hGetContents ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.Environment ( getArgs, getProgName ) +-- import System.Directory ( removeFile ) +import System.Console.GetOpt + +vERSION :: String +vERSION = "May 2005" + +getSrcFromStdin = + do putStrLn ("reading from stdin, finish program with a line containing " + ++ "only EOF") + read [] + where read acc = do l <- getLine + if l == "EOF" then return $ unlines (reverse acc) + else read (l : acc) + +analyse ast flags = + let on = \x -> elem x flags + in do symtab <- buildSymtab ast + runST symtab $ + do WFP.check ast + ast' <- kindInference ast + WFP.checkAfterKindInference ast' + when (on $ Dump KindInfer) $ + do liftIO $ dump (ppr ast') + kiDump <- dumpKindInference ast' + liftIO $ dump kiDump + + +dump :: Doc -> IO () +dump p = do hPutStrLn stdout (show p) + return () + +main :: IO () +main = do + args <- getArgs + prog <- getProgName + (flags,files) <- parseArgs args prog + + let on = \x -> elem x flags + + -- compiler error messages are propagated as exceptions + flip catchDyn (\dyn -> do + hFlush stdout + if (on NoLocation) + then hPutStrLn stderr (showWithoutLocation (dyn :: PException)) + else hPutStrLn stderr (show (dyn :: PException)) + exitWith (ExitFailure 1) + ) $ do + + src <- if null files + then getSrcFromStdin + else readFile (head files) + + -- lexer + tokens <- evaluate $ scan src + when (on $ Dump Lex) $ dump (text $ show tokens) + + -- parser + parseSyntax <- evaluate (parse tokens) + when (on $ Dump Parse) $ dump (ppr parseSyntax) + when (on $ Dump RawParse) $ dump (text $ show parseSyntax) + + -- syntax transformation + ast <- evaluate (transform parseSyntax) + when (on $ Dump AST) $ dump (ppr ast) + when (on $ Dump RawAST) $ dump (text $ show ast) + + analyse ast flags + + {- + -- type inference + typesyn <- evaluate $ fst (elaborate (syntax, objMap)) + dump (ppr typesyn) + -- when (on $ Dump Infer) $ dump (ppr typesyn) + when (on $ Dump RawInfer) $ dump (text $ show typesyn) + -} + + {- + -- type check + putStrLn "Type check ..." + evaluate $ tycheck typesyn + when (on $ Dump Final) $ dump (ppr typesyn) + when (on $ Dump RawFinal) $ dump (text $ show typesyn) + + -- interpreter + putStrLn "Interpreter not implemented" + --dump . ppr $ Eval.eval typesyn + -} + exitWith ExitSuccess + + + +-- --------------------------------------------------------------------- +-- Handling command line flags + +data Flag + = Version + | Help + | Dump Phase + | ViaHaskell + | ViaInterp + | KeepTmpFiles + | OptGhc String + | CmpAbsSyn + | NoLocation + deriving Eq + +data Phase + = Lex + | Parse + | RawParse + | AST + | RawAST + | KindInfer + | Infer + | RawInfer + | Final + | RawFinal + | Haskell + deriving Eq + +-- +-- associate concrete flags with their abstract representation +-- +opts :: [OptDescr Flag] +opts = + [ Option ['v'] ["version"] (NoArg Version) "version string" + , Option ['?'] ["help"] (NoArg Help) "this message" + + , Option [] ["dump-lex"] (NoArg (Dump Lex )) + "dump lexed tokens" + , Option [] ["dump-parse"] (NoArg (Dump Parse)) + "print syntax tree after parsing" + , Option [] ["dump-rawparse"] (NoArg (Dump RawParse)) + "dump data type after parsing" + , Option [] ["dump-ast"] (NoArg (Dump AST)) + "print abstract syntax tree" + , Option [] ["dump-rawast"] (NoArg (Dump RawAST)) + "dump abstract syntax data type" + , Option [] ["dump-kindinfer"] (NoArg (Dump KindInfer)) + "print syntax after type inference" + , Option [] ["dump-infer"] (NoArg (Dump Infer)) + "print syntax after type inference" + , Option [] ["dump-rawinfer"] (NoArg (Dump RawInfer)) + "print data type after type inference" + , Option [] ["dump-final"] (NoArg (Dump Final)) + "print final syntax, after type checking" + , Option [] ["dump-rawfinal"] (NoArg (Dump RawFinal)) + "print final data type, after type checking" + , Option [] ["dump-haskell"] (NoArg (Dump Haskell)) + "print generated haskell" + , Option [] ["no-location"] (NoArg NoLocation) + "do not print source file locations in error messages" + , Option ['H'] ["haskell"] (NoArg ViaHaskell) "compile to Haskell" + , Option ['I'] ["interpreter"] (NoArg ViaInterp) "run interpreter" + + , Option [] ["keep-tmps"] (NoArg KeepTmpFiles) "keep temporary files" + , Option [] ["cmp-abssyn"] (NoArg CmpAbsSyn) "compare two syntax trees" + , Option [] ["opth"] ((ReqArg (\s->OptGhc s)) "flag") + "extra arguments to the Haskell compiler"] + +-- +-- parse the args. +-- +-- we also short circuit here, for the known cases of --version or --help +-- +parseArgs :: [String] -> String -> IO ([Flag],[FilePath]) +parseArgs argv prog = case (getOpt Permute opts argv) of + + (flags,fs,[]) -> case () of { _ + | Version `elem` flags -> putStrLn vERSION >> exitWith ExitSuccess + | Help `elem` flags -> putStrLn usage >> exitWith ExitSuccess +-- | null fs -> error usage + | otherwise -> return (flags,fs) + } + (_,_,err) -> error $ concat err ++ usage + + where usage = usageInfo ("Usage: "++ prog ++" [OPTION...] file") opts + addfile ./Makefile hunk ./Makefile 1 +# +# Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons +# Stefan Wehr - http://www.stefanwehr.de +# GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) +# + +TOPDIR = . + +include $(TOPDIR)/mk/config.mk + +# this rule must remain first +#default: KindInference.o +default: boot all + +# +# Various variables +# + +# preprocessor for source locations in error messages +PP = $(TOPDIR)/pp/logpp + +HC_OPTS += -pgmF "$(PP)" -F +BIN_DEPS += mtl + +#HC_OPTS += -prof -auto-all +#HAPPY_OPTS += -di +CLEAN_FILES += Parser.hs Lexer.hs +#DERIVED_HAPPY_SRCS+= Parser.hs +#DERIVED_ALEX_SRCS+= Lexer.hs + +ALL_DIRS= . + +BIN= minhs +HS_BINS= $(BIN) + + +# +# read in suffix rules +# +include $(TOPDIR)/mk/rules.mk + +MAKEFLAGS += --no-builtin-rules +.SUFFIXES: + +# +# Let's run the testsuite +# +.PHONY: check +check: + @( cd tests/driver ; ./check ${TEST} ) + +# +# dependencies +# + +AbstractSyntax.o: ParseSyntax.hs + +CLEAN_FILES += $(TOPDIR)/depend + +ifneq ($(MAKECMDGOALS),clean) +-include $(TOPDIR)/depend +endif addfile ./Map.hs hunk ./Map.hs 1 - +{-# OPTIONS -cpp #-} +-- +-- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) +-- + +-- +-- | Compatibility code between Data.FiniteMap and Data.Map We use the +-- function names from Data.Map. +-- +module Map ( +#if __GLASGOW_HASKELL__ >= 604 + module Data.Map, + addList, +#else + Map, + empty, + insert, + insertWith, + delete, + update, + lookup, + toList, + fromList, + addList, + size, + elems, + singleton, + member, + keys, + assocs, + find, + (!), + + mapWithKey, + filterWithKey, + filter, + foldWithKey, +#endif + mapMaybe, + insertUpd, + insertLookup + ) where + +import Prelude hiding (lookup, filter) +import Data.Maybe (fromJust, isJust) + + +#if __GLASGOW_HASKELL__ >= 604 +import Data.Map + +addList :: (Ord k) => [(k,a)] -> Map k a -> Map k a +addList l m = union (fromList l) m + +#else +-- +-- compatibility code for deprecated FiniteMap +-- +import Prelude hiding (lookup, filter) +import qualified Data.FiniteMap as FM + +type Map = FM.FiniteMap + +instance Functor (Map k) where + fmap = FM.mapFM . const + +empty :: Map k a +empty = FM.emptyFM + +singleton :: k -> a -> Map k a +singleton = FM.unitFM + +insert :: Ord k => k -> a -> Map k a -> Map k a +insert = \k e m -> FM.addToFM m k e + +-- | This function is pure evil. Avoid it if possible. +-- Otherwise, always remember: The first argument of @f@ is the NEW value +-- (i.e we already know it), the second argument is the OLD value! +-- +-- Grrrrrrrr. +insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a +insertWith f k e m = FM.addToFM_C (flip f) m k e + +delete :: Ord k => k -> Map k a -> Map k a +delete = flip FM.delFromFM + +update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a +update f k m = case lookup k m of + Nothing -> m + Just v -> case f v of + Nothing -> delete k m + Just v' -> insert k v' m + +lookup :: Ord k => k -> Map k a -> Maybe a +lookup = flip FM.lookupFM + +fromList :: Ord k => [(k,a)] -> Map k a +fromList = FM.listToFM + +toList :: Map k a -> [(k,a)] +toList = FM.fmToList + +size :: Map k a -> Int +size = FM.sizeFM + +elems :: Map k a -> [a] +elems = FM.eltsFM + +member :: Ord k => k -> Map k a -> Bool +member = FM.elemFM + +keys :: Map k a -> [k] +keys = FM.keysFM + +assocs :: Map k a -> [(k, a)] +assocs = FM.fmToList + +addList :: (Ord k) => [(k, a)] -> Map k a -> Map k a +addList = flip FM.addListToFM + +-- delListFromFM = \fm keys -> foldl delete fm keys + +-- Posted by Gracjan Polak on haskell-cafe@ +-- note that we want the mapping the other way around. +-- +-- deleteList list map = foldl (flip Data.Map.delete) map list +-- insertList asclist map = union map (Data.Map.fromList asclist) +-- + +mapWithKey :: (k -> a -> b) -> Map k a -> Map k b +mapWithKey = FM.mapFM + +-- map f m == mapFM (const f) + +filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a +filterWithKey = FM.filterFM + +filter :: Ord k => (a -> Bool) -> Map k a -> Map k a +filter = filterWithKey . const + +foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b +foldWithKey = FM.foldFM + +infixl 9 ! +(!) :: Ord k => Map k a -> k -> a +m ! k = find k m + +-- | /O(log n)/. Find the value at a key. +-- Calls 'error' when the element can not be found. +find :: Ord k => k -> Map k a -> a +find k m = case lookup k m of + Nothing -> error "Map.find: element not in the map" + Just x -> x + +#endif + +-- | Data.Maybe.mapMaybe for Maps +mapMaybe :: Ord k => (a -> Maybe b) -> Map k a -> Map k b +mapMaybe f = fmap fromJust . filter isJust . fmap f + +-- | This makes way more sense than @insertWith@ because we don't need to +-- remember the order of arguments of @f@. +insertUpd :: Ord k => (a -> a) -> k -> a -> Map k a -> Map k a +insertUpd f = insertWith (\_ -> f) + +insertLookup :: Ord k => k -> a -> Map k a -> (Maybe a, Map k a) +insertLookup = insertLookupWithKey (\_ v _ -> v) addfile ./NameSpaces.hs hunk ./NameSpaces.hs 1 +-- Compiler Toolkit: name space management +-- +-- Author : Manuel M. T. Chakravarty +-- Created: 12 November 95 +-- +-- Adapted and modified by Stefan Wehr, May 2005 +-- +-- Version $Revision: 1.8 $ from $Date: 1999/10/24 14:36:52 $ +-- +-- Copyright (c) [1995..1999] Manuel M. T. Chakravarty +-- +-- This file is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- This file is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +--- DESCRIPTION --------------------------------------------------------------- +-- +-- This module manages name spaces. +-- +--- DOCU ---------------------------------------------------------------------- +-- +-- language: Haskell 98 +-- +-- * A name space associates identifiers with their definition. +-- +-- * Each name space is organized in a hierarchical way using the notion of +-- ranges. A name space, at any moment, always has a global range and may +-- have several local ranges. Definitions in inner ranges hide definitions +-- of the same identifiert in outer ranges. +-- +--- TODO ---------------------------------------------------------------------- +-- +-- * evaluate the performance gain that a hashtable would bring +-- + +module NameSpaces (NameSpace, nameSpace, defGlobal, enterNewRange, leaveRange, + defLocal, find, findGlobal, nameSpaceToList) +where + +import qualified Map +import Error +import Pretty + + +-- name space (EXPORTED ABSTRACT) +-- +-- * the definitions in the global ranges are stored in a finite map, because +-- they tend to be a lot and are normally not updated after the global range +-- is constructed +-- +-- * the definitions of the local ranges are stored in a single list, usually +-- they are not very many and the definitions entered last are the most +-- frequently accessed ones; the list structure naturally hides older +-- definitions, i.e., definitions from outer ranges; adding new definitions +-- is done in time proportinal to the current size of the range; removing a +-- range is done in constant time (and the definitions of a range can be +-- returned as a result of leaving the range); lookup is proportional to the +-- number of definitions in the local ranges and the logarithm of the number +-- of definitions in the global range---i.e., efficiency relies on a +-- relatively low number of local definitions together with frequent lookup +-- of the most recently defined local identifiers +-- +data NameSpace k v = NameSpace (Map.Map k v) -- defs in global range + [[(k, v)]] -- stack of local ranges + +-- create a name space (EXPORTED) +-- +nameSpace :: NameSpace k v +nameSpace = NameSpace Map.empty [] + +-- add global definition (EXPORTED) +-- +-- * returns the modfied name space +-- +-- * if the identfier is already declared, the resulting name space contains +-- the new binding and the second component of the result contains the +-- definition declared previosuly (which is henceforth not contained in the +-- name space anymore) +-- +defGlobal :: Ord k => k -> v -> NameSpace k v -> (Maybe v, NameSpace k v) +defGlobal id def (NameSpace gs lss) = (Map.lookup id gs, + NameSpace (Map.insert id def gs) lss) + +-- add new range (EXPORTED) +-- +enterNewRange :: NameSpace k v -> NameSpace k v +enterNewRange (NameSpace gs lss) = NameSpace gs ([]:lss) + +-- pop topmost range and return its definitions (EXPORTED) +-- +leaveRange :: NameSpace k v -> (NameSpace k v, [(k, v)]) +leaveRange (NameSpace gs []) = + panic "leaveRange called, but no local range exists" +leaveRange (NameSpace gs (ls:lss)) = (NameSpace gs lss, ls) + +-- add local definition (EXPORTED) +-- +-- * returns the modfied name space +-- +-- * if there is no local range, the definition is entered globally +-- +-- * if the identfier is already declared, the resulting name space contains +-- the new binding and the second component of the result contains the +-- definition declared previosuly (which is henceforth not contained in the +-- name space anymore) +-- +defLocal :: Ord k => k -> v -> NameSpace k v -> (Maybe v, NameSpace k v) +defLocal id def ns@(NameSpace gs []) = defGlobal id def ns +defLocal id def (NameSpace gs (ls:lss)) = + (lookup ls, + NameSpace gs (((id, def):ls):lss)) + where + lookup [] = Nothing + lookup ((id', def):ls) | id == id' = Just def + | otherwise = lookup ls + + +-- search for a definition (EXPORTED) +-- +-- * the definition from the innermost range is returned, if any +-- +find :: (Ord k) => k -> NameSpace k v -> Maybe v +find id (NameSpace gs lss) = case (lookup lss) of + Nothing -> Map.lookup id gs + Just def -> Just def + where + lookup [] = Nothing + lookup (ls:lss) = case (lookup' ls) of + Nothing -> lookup lss + Just def -> Just def + + lookup' [] = Nothing + lookup' ((id', def):ls) + | id' == id = Just def + | otherwise = lookup' ls + +findGlobal :: (Ord k) => k -> NameSpace k v -> Maybe v +findGlobal id (NameSpace gs lss) = Map.lookup id gs + +-- dump a name space into a list (EXPORTED) +-- +-- * local ranges are concatenated +-- +nameSpaceToList :: NameSpace k v -> [(k, v)] +nameSpaceToList (NameSpace gs lss) = Map.toList gs ++ concat lss addfile ./ParseSyntax.hs hunk ./ParseSyntax.hs 1 +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} + +#ifdef ABSTRACT_SYNTAX +module AbstractSyntax +#else +module ParseSyntax +#endif +where + +import List (intersperse,lookup,intersect,deleteBy) +import Builtins +import Pretty +import Error +import Substitution +import qualified Data.Set as Set +import qualified Builtins +import qualified Data.Generics as Gen + +#ifdef ABSTRACT_SYNTAX +import qualified UniqIdents +#else +#endif + +#ifdef ABSTRACT_SYNTAX +type TypeVarId = UniqIdents.TypeVarId +type TypeId = UniqIdents.TypeId +type ValId = UniqIdents.ValId +type DataId = UniqIdents.DataId +type ClassId = UniqIdents.ClassId +type AssocTypeId = UniqIdents.AssocTypeId +type MethodId = UniqIdents.MethodId + +isPairTypeConstructor = UniqIdents.isPairTypeConstructor +isFunTypeConstructor = UniqIdents.isFunTypeConstructor + +#else + +type Id = String +type TypeVarId = Id +type TypeId = Id +type ValId = Id +type DataId = Id +type ClassId = Id +type AssocTypeId = Id +type MethodId = Id + +isPairTypeConstructor = (==) Builtins.pairTypeConstructor +isFunTypeConstructor = (==) Builtins.funTypeConstructor + +#endif + +data Program = Program [TypeDef] [ClassDec] [ClassInst] [ValBind] + deriving (Read, Show, Eq, Gen.Data, Gen.Typeable) + +data TypeDef = TypeDef { tydef_name :: TypeId, + tydef_params :: [TypeVarId], + tydef_alts :: [DataConstructor] + } + deriving (Read, Show, Eq, Gen.Data, Gen.Typeable) + +data DataConstructor = DataConstructor { dconstr_name :: DataId, + dconstr_params :: [Type] } + deriving (Read, Show, Eq, Gen.Data, Gen.Typeable) + +data ClassDec = ClassDec { class_name :: ClassId, + class_param :: TypeVarId, + class_constraints :: [ClassConstraint], + class_tsigs :: [TSig], + class_vsigs :: [VSig] + } + deriving (Read, Show, Eq, Gen.Data, Gen.Typeable) + +type TSig = (AssocTypeId, [TypeVarId]) +type VSig = (MethodId, TypeScheme) + +data ClassInst = ClassInst { inst_class :: ClassId, + inst_type :: Type, + inst_constraints :: [Constraint], + inst_typeBind :: AssocTypeBind, + inst_valBinds :: [MethodBind] + } + deriving (Read, Show, Eq, Gen.Data, Gen.Typeable) + +data AssocTypeBind = AssocTypeBind { assocBind_name :: AssocTypeId, + assocBind_index :: Type, + assocBind_params :: [TypeVarId], + assocBind_def :: Type + } + deriving (Read, Show, Eq, Gen.Data, Gen.Typeable) + +data MethodBind = MethodBind { method_name :: MethodId, + method_params :: [ValId], + method_exp :: Exp + } + deriving (Read,Show,Eq, Gen.Data, Gen.Typeable) + +-- +-- Constraints +-- + +data ClassConstraint = ClassConstraint { cc_name :: ClassId, + cc_param :: Type + } + deriving (Read, Show, Eq, Gen.Data, Gen.Typeable) + +data EqConstraint = EqConstraint { eqc_left :: AssocType, + eqc_right :: Type + } + deriving (Read, Show, Eq, Gen.Data, Gen.Typeable) + +data Constraint = CC ClassConstraint + | EC EqConstraint + deriving (Read, Show, Eq, Gen.Data, Gen.Typeable) + + +-- +-- Types & Kinds +-- + +data Kind = KindStar + | KindFun Kind Kind + deriving (Read, Show, Eq, Gen.Data, Gen.Typeable) + +data Type + = TyVar TypeVarId -- a type var + | TyApp Type Type -- application + | TyConstruct TypeId -- regular type constructor or + | TyAssoc AssocType + deriving (Read, Show, Eq, Gen.Data, Gen.Typeable) + + +data AssocType = AssocType { assoc_name :: AssocTypeId, + assoc_params :: [Type] + } + deriving (Read, Show, Eq, Gen.Data, Gen.Typeable) + +data QualifiedType + = ConstrainedType [Constraint] Type + | UnconstrainedType Type + deriving (Read, Show, Eq, Gen.Data, Gen.Typeable) + +data TypeScheme + = TypeScheme [TypeVarId] QualifiedType + deriving (Read,Show,Eq, Gen.Data, Gen.Typeable) + + +-- +-- Useful operations on Types. Most of them are only needed for types of the +-- AbstractSyntax module, but we implement them here because we want to +-- apply some operations in ParseSyntax types as well. +-- + +type TypeSubst = Subst TypeVarId Type + +class Substitution TypeVarId Type a => Types a where + freeTypeVars :: a -> Set.Set TypeVarId + fixedTypeVars :: a -> Set.Set TypeVarId + +instance Substitution TypeVarId Type Type where + applySubst s t@(TyVar id) = + case substLookup id s of + Just t' -> t' + Nothing -> t + applySubst s (TyApp t1 t2) = + TyApp (applySubst s t1) (applySubst s t2) + applySubst s t@(TyConstruct _) = t + applySubst s (TyAssoc t) = TyAssoc (applySubst s t) + +instance Types Type where + freeTypeVars t = + case t of + TyVar i -> Set.singleton i + TyApp t1 t2 -> Set.union (freeTypeVars t1) (freeTypeVars t2) + TyConstruct _ -> Set.empty + TyAssoc at -> freeTypeVars at + fixedTypeVars t = + case t of + TyVar i -> Set.singleton i + TyApp t1 t2 -> Set.union (fixedTypeVars t1) (fixedTypeVars t2) + TyConstruct _ -> Set.empty + TyAssoc at -> fixedTypeVars at + +instance Substitution TypeVarId Type AssocType where + applySubst s (AssocType id ts) = AssocType id (applySubst s ts) + +instance Types AssocType where + freeTypeVars (AssocType _ ts) = + Set.unions (map freeTypeVars ts) + fixedTypeVars _ = Set.empty + +instance Substitution TypeVarId Type QualifiedType where + applySubst s (ConstrainedType c t) = + ConstrainedType (applySubst s c) (applySubst s t) + applySubst s (UnconstrainedType t) = + UnconstrainedType (applySubst s t) + +instance Types QualifiedType where + freeTypeVars (ConstrainedType c t) = + freeTypeVars c `Set.union` freeTypeVars t + freeTypeVars (UnconstrainedType t) = freeTypeVars t + fixedTypeVars (UnconstrainedType t) = fixedTypeVars t + fixedTypeVars (ConstrainedType c t) = + fixedTypeVars c `Set.union` fixedTypeVars t + +instance Substitution TypeVarId Type TypeScheme where + applySubst s (TypeScheme quant t) = + let s' = foldr removeFromSubst s quant + in TypeScheme quant (applySubst s' t) + +instance Types TypeScheme where + freeTypeVars (TypeScheme quant t) = + freeTypeVars t `Set.difference` (Set.fromList quant) + fixedTypeVars (TypeScheme quant t) = + fixedTypeVars t `Set.difference` (Set.fromList quant) + +instance Substitution TypeVarId Type Constraint where + applySubst s (CC (ClassConstraint id t)) = + CC (ClassConstraint id (applySubst s t)) + applySubst s (EC (EqConstraint t1 t2)) = + EC (EqConstraint (applySubst s t1) (applySubst s t2)) + +instance Types Constraint where + freeTypeVars (CC (ClassConstraint _ t)) = freeTypeVars t + freeTypeVars (EC (EqConstraint t1 t2)) = + freeTypeVars t1 `Set.union` freeTypeVars t2 + fixedTypeVars (CC (ClassConstraint _ _)) = Set.empty + fixedTypeVars (EC (EqConstraint _ t2)) = fixedTypeVars t2 + +instance Types a => Types [a] where + freeTypeVars l = Set.unions (map freeTypeVars l) + fixedTypeVars l = Set.unions (map fixedTypeVars l) + +freeTypeVarsList t = Set.toList $ freeTypeVars t +fixedTypeVarsList t = Set.toList $ fixedTypeVars t + +-- +-- Expression +-- + +data Exp + = Var ValId -- variables + | Num Integer -- numbers + + | Prim Op [Exp] -- primitive operations (always saturated) + | Con DataId [Exp] -- constructor (a function) (always saturated) + + | App Exp Exp -- application: e1 e2 + | Lam [ValId] Exp -- abstraction: \x.e + + | If Exp Exp Exp + + | Let [ValBind] Exp -- let x = e1 in e2 + | Letrec [ValBind] Exp -- letrec a = e1 ; b = e2 ... in e3 + + | Case Exp [Alt] -- case e of a1 ; a2 .. aN + deriving (Read,Show,Eq, Gen.Data, Gen.Typeable) + +data ValBind = ValBind { vbind_name :: ValId, + vbind_type :: (Maybe TypeScheme), + vbind_params :: [ValId], + vbind_exp :: Exp + } + deriving (Read,Show,Eq, Gen.Data, Gen.Typeable) + +data Alt = Alt DataId [ValId] Exp -- tag var -> exp + deriving (Read,Show,Eq, Gen.Data, Gen.Typeable) + +-- +-- Pretty Printing +-- + +tyFunAppSpec = (RightAssoc, 2) +tyAppSpec = (LeftAssoc, 3) + +instance Pretty Kind where + pprPrec prec KindStar = text "*" + pprPrec prec (KindFun k1 k2) = + pprInfixOp prec tyFunAppSpec k1 (space <> text "->" <> space) k2 + +instance Pretty Type where + pprPrec prec ty = case ty of + TyVar t -> pprPrec prec t + TyApp (TyApp (TyConstruct id) t1) t2 + | isPairTypeConstructor id -> + parens (pprPrec minPrec t1 <> comma <+> + pprPrec minPrec t2) + | isFunTypeConstructor id -> + pprInfixOp prec tyFunAppSpec t1 (space <> text "->" <> space) t2 + TyApp t1 t2 -> pprInfixOp prec tyAppSpec t1 space t2 + TyConstruct id -> pprPrec prec id + TyAssoc assoc -> pprPrec prec assoc + +assocTypeSpec = tyAppSpec +instance Pretty AssocType where + pprPrec prec (AssocType name params) = + foldl (\t1 t2 -> pprInfixOp prec assocTypeSpec t1 space t2) + (ppr name) + params + +qualifiedTypeSpec = (NoAssoc, 0) +instance Pretty QualifiedType where + pprPrec prec (ConstrainedType constrs ty) = + pprInfixOp prec qualifiedTypeSpec + (punctuate (char ',') (map ppr constrs)) + (space <> text "=>" <> space) + ty + pprPrec prec (UnconstrainedType ty) = pprPrec prec ty + +typeSchemeSpec = (NoAssoc, 0) +instance Pretty TypeScheme where + pprPrec prec (TypeScheme vars qtype) = + if null vars + then pprPrec prec qtype + else pprInfixOp prec typeSchemeSpec + (text "forall" <+> ppr vars) + (space <> char '.' <> space) + qtype + +instance Pretty Constraint where + pprPrec prec (CC cc) = pprPrec prec cc + pprPrec prec (EC ec) = pprPrec prec ec + +eqConstraintSpec = (NoAssoc, 0) +instance Pretty EqConstraint where + ppr (EqConstraint left right) = + pprInfixOp minPrec eqConstraintSpec left (space <> text "=" <> space) + right + +classConstraintSpec = (NoAssoc, 1) +instance Pretty ClassConstraint where + ppr (ClassConstraint name param) = + ppr name <+> pprPrec maxPrec param + +instance Pretty ClassInst where + ppr (ClassInst name ty constrs tyBind valBinds) = + text "instance" <+> parens (hsep (punctuate comma (map ppr constrs))) + <+> text "=>" <+> ppr name <+> pprPrec maxPrec ty <+> text "where" $$ + nest 4 (vcat ([ppr tyBind] ++ (map ppr valBinds))) + +instance Pretty AssocTypeBind where + ppr (AssocTypeBind name index params def) = + ppr name <+> pprPrec maxPrec index <+> hsep (map ppr params) + <+> text "=" <+> ppr def + +dataConstructorSpec = tyAppSpec +instance Pretty DataConstructor where + pprPrec prec (DataConstructor name params) = + foldl (\t1 t2 -> pprInfixOp prec dataConstructorSpec t1 space t2) + (ppr name) params + +instance Pretty TSig where + ppr (id, tyvars) = ppr id <+> hsep (map ppr tyvars) + +instance Pretty VSig where + ppr (id, ty) = ppr id <::> ppr ty + +instance Pretty ClassDec where + ppr (ClassDec name param constrs tsigs vsigs) = + text "class" <+> parens (hsep (punctuate comma (map ppr constrs))) + <+> text "=>" <+> ppr name <+> ppr param <+> text "where" $$ + nest 4 (vcat (map ppr tsigs ++ map ppr vsigs)) + +instance Pretty TypeDef where + ppr (TypeDef name params alts) = + text "data" <+> ppr name <+> hsep (map ppr params) <+> text "=" $$ + if not (null alts) + then nest 4 (vcat ([ppr (head alts)] ++ + map (\a -> text "|" <+> ppr a) (tail alts))) + else empty + +instance Pretty Program where + ppr (Program tydefs classDecs classInsts binds) = + vcat (map ppr tydefs ++ map ppr classDecs ++ map ppr classInsts + ++ map ppr binds) + +instance Pretty ValBind where + ppr (ValBind x Nothing vars e) = + ppr x <+> hsep (map ppr vars) <=> ppr e + ppr (ValBind x (Just ty) vars e) = + vcat [ppr x <::> ppr ty, + ppr x <+> hsep (map ppr vars) <=> ppr e] + +instance Pretty MethodBind where + ppr (MethodBind x vars e) = + ppr x <+> hsep (map ppr vars) <=> ppr e + +instance Pretty Alt where + ppr (Alt tag xs e) = ppr tag <+> hsep (map ppr xs) <->> ppr e <> semi + +appSpec = (LeftAssoc, 9) + +instance Pretty Exp where + pprPrec _ (Var v) = ppr v + pprPrec _ (Num i) = text $ show i + + -- because of eta-expansion, es are variables and the whole (Con ...) + -- expression is wrapped in a lambda + pprPrec _ (Con tag es) = ppr tag <+> hsep (map ppr es) + + pprPrec prec (Prim op es) = + let opSpec@(assoc, opPrec) = specOfPrimOp op + opStr = primOpToStr op + arity = arityOfPrimOp op + in if arity /= length es + then panic ("arity of primOp " ++ show op ++ " and length " + ++ "of argument list do not match") + else case arity of + 1 -> parens `usedWhen` (prec > opPrec) $ + text opStr <> pprPrec opPrec (es!!0) + 2 -> let e1 = es!!0 + e2 = es!!1 + in pprInfixOp prec opSpec e1 + (space <> text opStr <> space) e2 + i -> panic ("unexpected arity " ++ show i ++ + "of primOp " ++ show op) + + pprPrec prec (App e1 e2) = + pprInfixOp prec appSpec e1 space e2 + + pprPrec prec (Lam xs e) = + parens `usedWhen` (prec > minPrec) $ + char '\\' <> (hsep (map ppr xs)) <->> ppr e + + pprPrec prec (If e e1 e2) = + parens `usedWhen` (prec > minPrec) $ + hang (text "if" <+> ppr e) + 4 ( (text "then" <+> ppr e1) $$ + (text "else" <+> ppr e2) ) + + pprPrec prec (Let bs e) = + parens `usedWhen` (prec > minPrec) $ + text "let" $$ nest 4 + (vcat $ intersperse semi (map ppr bs)) $$ + hang (text "in") 4 (ppr e) + + pprPrec prec (Letrec bs e) = + parens `usedWhen` (prec > minPrec) $ + text "letrec" $$ nest 4 + (vcat $ intersperse semi (map ppr bs)) $$ + hang (text "in") 4 (ppr e) + + pprPrec prec (Case e alts) = + parens `usedWhen` (prec > minPrec) $ + text "case" <+> parens(ppr e) <+> text "of" $$ + nest 4 (vcat $ (map ppr alts)) + + addfile ./Parser.y hunk ./Parser.y 1 +-- +-- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Gabriele Keller (keller@cse.unsw.edu.au) +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- + +-- +-- This parser specifies the majority of the concrete syntax of +-- MiniHaskell +-- +-- The parser also does some desugaring, converting infix to prefix +-- form, for one. +-- +-- Extensions: +-- Parses the syntax described in 'Associated Type Synonym' Paper +-- +-- TODO: new version of paper handles superclasses, this is not +-- yet implemented + +{ + +{-# OPTIONS -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-incomplete-patterns #-} +-- ^ grr. happy needs them all on one line + +module Parser ( parse ) where + +import ParserHelper +import ParseSyntax +import Lexer +import Error ( phasefail_ ) +import Builtins + +} + +-- we'll just let any specials/reservedXs die as happyErrors, at the moment + +%name parse +%tokentype { Token } +%token + '(' { T _ (SpecialT '(') } + ')' { T _ (SpecialT ')') } + '{' { T _ (SpecialT '{') } + '}' { T _ (SpecialT '}') } + '`' { T _ (SpecialT '`') } + ';' { T _ (SpecialT ';') } + ',' { T _ (SpecialT ',') } + 'if' { T _ (ReservedIdT "if") } + 'then' { T _ (ReservedIdT "then") } + 'else' { T _ (ReservedIdT "else") } + 'case' { T _ (ReservedIdT "case") } + 'class' { T _ (ReservedIdT "class") } + 'data' { T _ (ReservedIdT "data") } + 'of' { T _ (ReservedIdT "of") } + 'let' { T _ (ReservedIdT "let") } + 'letrec' { T _ (ReservedIdT "letrec") } + 'type' { T _ (ReservedIdT "type") } + 'in' { T _ (ReservedIdT "in") } +-- 'forall' { T _ (ReservedIdT "forall") } + 'instance' { T _ (ReservedIdT "instance") } + 'where' { T _ (ReservedIdT "where") } + '::' { T _ (ReservedOpT "::") } + '=' { T _ (ReservedOpT "=") } + '|' { T _ (ReservedOpT "|") } + '\\' { T _ (ReservedOpT "\\") } -- unused atm + '->' { T _ (ReservedOpT "->") } + '=>' { T _ (ReservedOpT "=>") } + '-' { T _ (ReservedOpT "-") } + '*' { T _ (VarSymT "*") } -- product types ! + '+' { T _ (VarSymT "+") } -- sum types ! +-- '.' { T _ (VarSymT ".") } + INT { T _ (IntegerT $$) } +-- FLOAT { T _ (FloatT $$) } +-- CHAR { T _ (CharT $$) } +-- STRING { T _ (StringT $$) } + VARID { T _ (VarIdT $$) } -- variables + CONID { T _ (ConIdT $$) } -- constructors | tycon + VARSYM { T _ (VarSymT $$) } + CONSYM { T _ (ConSymT $$) } +%% + +p :: { Program } + : prgElems { mkProgram (reverse $1) } + +prgElems :: { [PrgElem] } + : prgElems typeDef {PrgTypeDef $2 : $1} + | prgElems classDec {PrgClassDec $2 : $1} + | prgElems classInst {PrgClassInst $2 : $1} + | prgElems valBind ';' {PrgBind $2 : $1} + | {-epsilon-} { [] } + +typeDef :: {TypeDef} + : 'data' tycon etyvars '=' talt talts ';' { TypeDef $2 (reverse $3) + ($5 : reverse $6) } + +talts:: { [DataConstructor] } + : talts '|' talt {$3 : $1} + | {-epsilon-} {[]} + +talt :: { DataConstructor } + : tycon atypes { DataConstructor $1 $2 } + +classDec:: { ClassDec } + : 'class' head 'where' '{' tsigs vsigs '}' + { mkClassDec $2 (reverse $5) (reverse $6) } + +tsigs:: { [TSig] } + : tsigs tsig ';'{ $2 : $1} + |{- epsilon -} {[]} + +tsig:: { TSig } + : 'type' tycon tyvars { ($2, (reverse $3)) } + + +vsigs:: { [VSig] } + : vsigs vsig ';' { $2 : $1} + | {- epsilon -} {[]} + + +vsig:: { VSig } + : var '::' qualifiedType { ($1, TypeScheme [{- fill later -}] $3) } + + + +classInst:: { ClassInst } + : 'instance' head 'where' '{' assocType ';' methodBinds '}' + { mkClassInst $2 $5 (reverse $7)} + +assocType:: { AssocTypeBind } + : 'type' tycon atype etyvars '=' type + { (AssocTypeBind $2 $3 (reverse $4) $6) } + + +head :: { ([Constraint], Type) } + : context '=>' type { ($1, $3) } + | type { ([], $1) } + +context :: { [Constraint] } + : constraints { reverse $1 } + +constraints :: { [Constraint] } + : constraints ',' constraint { $3 : $1 } + | constraint { [$1] } + +constraint :: { Constraint } + : type '=' type { EC (mkEqConstraint $1 $3) } + | type { CC (mkClassConstraint $1) } + + + +-- non-empty list of tyvars +tyvars:: { [TypeVarId] } + : tyvar { [$1] } + | tyvars tyvar { $2 : $1 } + +-- poss. empty list of tyvars +etyvars:: { [TypeVarId] } + : {-epsilon-} { [] } + | etyvars tyvar { $2 : $1 } + + +methodBinds :: { [MethodBind] } + : methodBinds methodBind ';' { $2 : $1 } + | {-epsilon-} { [] } + +methodBind :: { MethodBind } + : var vars '=' exp { MethodBind $1 $2 $4 } + +valBinds :: { [ValBind] } + : valBinds valBind ';' { $2 : $1 } + | {-epsilon-} { [] } + +-- types are optional +valBind :: { ValBind } + : var '::' qualifiedType ';' var vars '=' exp + { if $1 == $5 + then ValBind $1 (Just (TypeScheme [{-fill later-}] $3)) $6 $8 + else phasefail + "parse error: different variables in explicitly typed binding" + } + | var vars '=' exp { ValBind $1 Nothing $2 $4 } + +-- expressions (based on Haskell) +exp :: { Exp } + : exp0a { $1 } + | exp0b { $1 } + +-- n.b. have to then flatten to primops +exp0a :: { Exp } + : exp0b op exp10a { App (App (Var $2) $1) $3 } -- un-infix + | exp10a { $1 } + +exp0b :: { Exp } + : exp0b op exp10b { App (App (Var $2) $1) $3 } -- un-infix + | exp10b { $1 } + +exp10a :: { Exp } + : '\\' var vars '->' exp { Lam ($2:reverse $3) $5 } + | 'let' valBinds 'in' exp { Let (reverse $2) $4 } + | 'letrec' valBinds 'in' exp { Let (reverse $2) $4 } + | 'if' exp 'then' exp 'else' exp { If $2 $4 $6 } + +exp10b :: { Exp } + : 'case' exp 'of' alts { Case $2 $4 } + | '-' fexp { Prim IntNegOp [$2] } -- NB + | fexp { $1 } + +fexp :: { Exp } + : fexp aexp { App $1 $2 } + | aexp { $1 } + +aexp :: { Exp } + : var { Var $1 } + | num { Num $1 } + | '(' exp ')' { $2 } + | '(' ')' { Con (fst unitDataConstructor) [] } + | '(' exp ',' exp ')' { Con (fst pairDataConstructor) [$2,$4] } + | con { Con $1 [ {-filled later-} ] } + +{- +explist :: { [Exp] } + : {-epsilon-} { [] } + | explist ',' exp { $3 : $1 } +-} +-- ----------------------------------------------------------- + +alts :: { [ Alt ] } +alts : alts alt { $2 : $1 } -- would prefer: alts ';' alt + | alt { [$1] } + +alt :: { Alt } + : con vars '->' exp ';' { Alt $1 $2 $4 } + +-- ----------------------------------------------------------- +-- types + +type:: {Type} + : btype '->' type { TyApp (TyApp (TyConstruct funTypeConstructor) + $1) $3 } + | '(' type ',' type ')' { TyApp (TyApp (TyConstruct pairTypeConstructor) + $2) $4 } + | btype { $1 } + + +btype :: {Type} + : btype atype {TyApp $1 $2 } + | atype { $1 } + +atype :: {Type} + : tycon { TyConstruct $1 } + | tyvar { TyVar $1 } + | '(' type ')' { $2 } + +qualifiedType :: { QualifiedType } + : context '=>' type { ConstrainedType $1 $3 } + | type { UnconstrainedType $1 } + + +atypes :: {[Type]} + : atypes atype {$1 ++ [$2]} + | {- epsilon -} {[]} + + +-- ----------------------------------------------------------- +-- Variables, Constructors and Operators. + +vars :: { [Id] } + : vars var { $1 ++ [$2] } -- hmmm + | {-epsilon-} { [] } + +var :: { Id } + : varid { $1 } + | '(' varsym ')' { $2 } + +con :: { Id } + : conid { $1 } + | '(' consym ')' { $2 } + +varop :: { Id } + : varsym { $1 } + | '-' { "-" } -- dyadic "subtract" + | '+' { "+" } -- not the type constructor + | '*' { "*" } -- not the type constructor + | '`' varid '`' { $2 } + +conop :: { Id } + : consym { $1 } + | '`' conid '`' { $2 } + +op :: { Id } + : varop { $1 } + | conop { $1 } + +tycon :: { Id } + : conid { $1 } + +tyvar :: { Id } + : varid { $1 } + +num :: { Integer } + : INT { $1 } + +-- ----------------------------------------------------------- +-- Identifiers and Symbols + +varid :: { Id } + : VARID { $1 } + +conid :: { Id } + : CONID { $1 } + +consym :: { Id } + : CONSYM { $1 } + +varsym :: { Id } + : VARSYM { $1 } + +------------------------------------------------------------------------ + +{ + +happyError :: [Token] -> a +happyError x = + let next3 = concatMap showPosToken (take 3 x) + in phasefail ("Parser error, next tokens: " ++ next3) + where showPosToken (T p tk) = + "\n " ++ showPos p ++ ", " ++ show tk + +} addfile ./ParserHelper.hs hunk ./ParserHelper.hs 1 - +module ParserHelper where + +import Maybe (mapMaybe) + +import ParseSyntax +import Pretty +import Error + +data PrgElem = PrgTypeDef TypeDef + | PrgClassDec ClassDec + | PrgClassInst ClassInst + | PrgBind ValBind + +builtins = [TypeDef "Int" [] [], + TypeDef "Bool" [] [DataConstructor "False" [], + DataConstructor "True" []], + TypeDef "->" ["1", "2"] [], + TypeDef "Unit" [] [DataConstructor "()" []], + TypeDef "(,)" ["3", "4"] [DataConstructor "Pair" + [TyVar "3", TyVar "4"]]] + +addBuiltins (Program types classes insts binds) = + Program (builtins++types) classes insts binds + +mkProgram :: [PrgElem] -> Program +mkProgram l = + let p = Program types classes insts binds + in addBuiltins p + where + types = mapMaybe (\e -> case e of PrgTypeDef d -> Just d; _ -> Nothing) l + classes = mapMaybe (\e -> case e of PrgClassDec d -> Just d; _ -> Nothing) l + insts = mapMaybe (\e -> case e of PrgClassInst d -> Just d; _ -> Nothing) l + binds = mapMaybe (\e -> case e of PrgBind d -> Just d; _ -> Nothing) l + +mkClassDec :: ([Constraint], Type) -> [TSig] -> [VSig] -> ClassDec +mkClassDec (cs, (TyApp (TyConstruct i) (TyVar v))) tsigs vsigs = + ClassDec i v (map toClassConstraint cs) tsigs vsigs + where toClassConstraint (CC cc) = cc + toClassConstraint c@(_) = + phasefail ("illegal class constraint:" ++ show (ppr c)) +mkClassDec _ _ _ = phasefail "illegal class declaration" + +mkClassInst :: ([Constraint], Type) -> AssocTypeBind -> [MethodBind] + -> ClassInst +mkClassInst (cs, (TyApp (TyConstruct i) t)) assoc vals = + ClassInst i t cs assoc vals + + +mkEqConstraint :: Type -> Type -> EqConstraint +mkEqConstraint t1 t2 = + let (name, params) = (fst $ splitConstr t1, reverse.snd $ splitConstr t1) + in if null params + then phasefail ("Illegal AT in equality constraint: " ++ + show (ppr t1)) + else EqConstraint (AssocType name params) t2 + where + splitConstr (TyApp (TyConstruct tc) t) = (tc, [t]) + splitConstr (TyApp t1 t2) = + let (tc,ts) = splitConstr t1 in (tc, t2:ts) + +mkClassConstraint :: Type -> ClassConstraint +mkClassConstraint (TyApp (TyConstruct i) t) = ClassConstraint i t +mkClassConstraint t@(_) = phasefail ("Illegal class constraint: " ++ + show (ppr t)) addfile ./Pretty.hs hunk ./Pretty.hs 1 +-- +-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- + +module Pretty ( + + Pretty(..), {- instances -} + printDoc, showPpr, + + -- helper + Precedence, minPrec, maxPrec, Assoc(..), OpSpec, pprInfixOp, usedWhen, + + -- our own combinators + (<::>),(<:>), (<=>), (<->>), + + module Text.PrettyPrint + + ) where + +-- +-- Just reexport the standard pretty printer at the moment, however, we +-- may add more ppr combinators here +-- + +import Text.PrettyPrint +import System.IO + +type Precedence = Int +minPrec,maxPrec :: Precedence +minPrec = 0 +maxPrec = 10 + +class Pretty a where + pprPrec :: Precedence -> a -> Doc + pprPrec _ = ppr + ppr :: a -> Doc + ppr = pprPrec 0 + +instance Pretty Int where pprPrec _ i = text (show i) +instance Pretty Bool where pprPrec _ = text . show +instance Pretty Char where pprPrec _ = char +instance Pretty a => Pretty [a] where + pprPrec prec s = hcat $ map (pprPrec prec) s +instance Pretty Doc where pprPrec _ = id + +showPpr :: Pretty p => p -> String +showPpr = show . ppr + +-- +-- stolen from $fptools/ghc/compiler/utils/Pretty.lhs +-- +-- This code has a BSD-style license +-- +printDoc :: Mode -> Handle -> Doc -> IO () +printDoc m hdl doc = do + fullRender m cols 1.5 put done doc + hFlush hdl + where + put (Chr c) next = hPutChar hdl c >> next + put (Str s) next = hPutStr hdl s >> next + put (PStr s) next = hPutStr hdl s >> next + + done = hPutChar hdl '\n' + + cols = 80 + + +-- partly stolen from http://www.cse.unsw.edu.au/~chak/haskell/code/Pretty.hs +-- associativity of an infix operator +-- +data Assoc = LeftAssoc | RightAssoc | NoAssoc + deriving (Eq) + +-- conditionally apply a document transformer +-- +-- * typically a function like `parens' is applied when the precedences require +-- this +-- +usedWhen :: (Doc -> Doc) -> Bool -> Doc -> Doc +usedWhen wrap c doc | c = wrap doc + | otherwise = doc + +-- associativity and precedence of an operator +type OpSpec = (Assoc, Precedence) + +-- precedence for the left branch of a binary operator given the +-- associativity and the precedence of the operator. +leftPrec :: OpSpec -> Precedence +leftPrec (opAssoc, opPrec) = + if (opAssoc == RightAssoc) then opPrec + 1 else opPrec + +-- the same for the right branch +rightPrec :: OpSpec -> Precedence +rightPrec (opAssoc, opPrec) = + if (opAssoc == LeftAssoc) then opPrec + 1 else opPrec + +pprInfixOp :: (Pretty left, Pretty right, Pretty op) => + Precedence -- context precedence + -> OpSpec -- specification for the operator + -> left -> op -> right -> Doc +pprInfixOp prec spec left op right = + parens `usedWhen` (prec > snd spec) $ + (pprPrec (leftPrec spec) left <> + ppr op <> + pprPrec (rightPrec spec) right) + + +-- --------------------------------------------------------------------- +-- some stuff we use + +infixl 6 <::> +infixl 6 <:> +infixl 6 <=> +infixl 6 <->> + +(<::>), (<:>), (<=>), (<->>) :: Doc -> Doc -> Doc + +p <::> q = p <> text " :: " <> q +p <:> q = p <> text " : " <> q +p <=> q = p <> text " = " <> q +p <->> q = p <> text " -> " <> q addfile ./README hunk ./README 1 + +------------------------------------------------------------------------ +-- Interpreter/compiler for the MinHS language +------------------------------------------------------------------------ + +This is an interpreter and compiler for the MinHS language, a language +based on MinML, as found in Bob Harper's book "Programming Languages : +Theory and Practice". MinHS differs from MinML in that its syntax is +based on that of Haskell, instead of ML, and it implements various +extensions to make the language more use friendly. + +More documentation can be found in the doc/ directory. + +Porting: +------- + +It's GHC-specific Haskell, at least the haskell-backend generated code +is. The compiler itself isn't necessarily tied to GHC. It should work +on any platform with a recent GHC. Untested on < GHC 6.2, although +some attempts have been made to make it work with at least the 6.x +series. + +It has been confirmed to work on ia64/linux and amd64/openbsd + +Building: +-------- + + autoreconf + ./configure + +Edit config.mk for your environment, then type + "make" +or + "make clean" + "make distclean" + +Should work with GNU make. + +Running: +------- + + Usage: minhs [OPTION...] file + -v --version version string + --help this message + --dump-parsed dump the parsed code + --dump-haskell dump generated haskell + -H --haskell compile to Haskell + --keep-tmps keep temporary files + --optghc=flag extra arguments to GHC + +For example, to compile to a Haskell binary: + + minhs -H foo.mhs + +will create the binary "foo" in the pwd. + addfile ./Substitution.hs hunk ./Substitution.hs 1 - +{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} +-- glasgow-exts: multi-param typeclasses +-- undecidable-instances: default instance for SubstParams (see below) + +module Substitution ( + Subst, Substitution(..), + showSubst, nullSubst, (+->), removeFromSubst, composeSubst, + mergeSubst, substLookup, substFromAssocs +) where + +import Pretty +import List +import Maybe + +data Subst a b = Subst [(a, b)] + +-- The SubstParams class is only a shortcut for the constraints +-- in the class context. Only one instance will ever exists, because +-- we do not export the class at all. For this instance, we need +-- the flag -fallow-undecidable-instances +class (Pretty a, Pretty b, Ord a, Eq b) => SubstParams a b where +instance (Pretty a, Pretty b, Ord a, Eq b) => SubstParams a b where + + +-- The class substitution states that a substitution from a to b can +-- be applied to values of type c. +class SubstParams a b => Substitution a b c where + applySubst :: Subst a b -> c -> c + +instance Substitution a b c => Substitution a b [c] where + applySubst s ts = map (applySubst s) ts + +showSubst :: (SubstParams a b) => Subst a b -> String +showSubst (Subst s) = + "[" ++ + (concat . intersperse ", ") + (map (\ (v,t) -> showPpr v ++ " -> " ++ showPpr t) s) + ++ "]" + +nullSubst :: (SubstParams a b) => Subst a b +nullSubst = Subst [] + +(+->) :: (SubstParams a b) => a -> b -> Subst a b +(+->) id t = Subst [(id,t)] + +removeFromSubst :: (SubstParams a b) => a -> Subst a b -> Subst a b +removeFromSubst id (Subst l) = Subst (remove id l) + where remove _ [] = [] + remove id ((id',t):rest) + | id == id' = rest + | otherwise = (id',t) : remove id rest + +composeSubst :: (Substitution a b b) => Subst a b -> Subst a b -> Subst a b +composeSubst s1@(Subst s1') (Subst s2') = + Subst $ [(u, applySubst s1 t) | (u,t) <- s2'] ++ s1' + +mergeSubst :: (SubstParams a b, Monad m) + => Subst a b -> Subst a b -> m (Subst a b) +mergeSubst s1@(Subst s1') s2@(Subst s2') = + if agree + then return (Subst (s1' ++ s2')) + else fail ("merging substitutions failed. s1 = " ++ + showSubst s1 ++ ", s2 = " ++ showSubst s2) + where agree = all (\v -> fromJust (substLookup v s1) + == fromJust (substLookup v s2)) + (map fst s1' `intersect` map fst s2') + + +substLookup :: (Monad m, SubstParams a b) => a -> Subst a b -> m b +substLookup x (Subst l) = + case lookup x l of + Just y -> return y + Nothing -> fail ("key " ++ showPpr x ++ " not found in substitution " + ++ showSubst (Subst l)) + +substFromAssocs :: [(a,b)] -> Subst a b +substFromAssocs l = Subst l addfile ./Symtab.hs hunk ./Symtab.hs 1 +module Symtab ( + + Symtab, buildSymtab, + + ST, liftIO, modify, gets, get, runST, + + insertKind, kindOfTypeVarId, kindAssocs, + + findClass, findAssocTypeSig, findClassOfAssocType, findInstances, + findTypeDef + +) where + +import qualified List +import qualified Map +import Control.Monad.State +import Pretty +import AbstractSyntax +import Error +import DependAnalysis + +data Symtab = Symtab + { classMap :: Map.Map ClassId (ClassDec, [ClassInst]), + assocTypeSigMap :: Map.Map AssocTypeId TSig, + typeVarKindMap :: Map.Map TypeVarId Kind, + typeDefMap :: Map.Map TypeId TypeDef + } + +emptySymtab = Symtab { classMap = Map.empty, + assocTypeSigMap = Map.empty, + typeVarKindMap = Map.empty, + typeDefMap = Map.empty } + +type ST = StateT Symtab IO + +runST :: Symtab -> ST a -> IO a +runST tab st = evalStateT st tab + +lookUp :: (Ord k, Pretty k) => (Symtab -> Map.Map k a) -> k -> ST a +lookUp f k = + do tab <- gets f + case Map.lookup k tab of + Just x -> return x + Nothing -> phasefail ("Key `" ++ showPpr k ++ + "' not found in symbol table") + +findInstances :: ClassId -> ST [ClassInst] +findInstances cid = + do (_, insts) <- lookUp classMap cid + return insts + +findClass :: ClassId -> ST ClassDec +findClass cid = + do (cdec, _) <- lookUp classMap cid + return cdec + +findAssocTypeSig :: AssocTypeId -> ST TSig +findAssocTypeSig = lookUp assocTypeSigMap + +findTypeDef :: TypeId -> ST TypeDef +findTypeDef = lookUp typeDefMap + +findClassOfAssocType :: AssocTypeId -> ST ClassDec +findClassOfAssocType id = + do tab <- gets classMap + case List.find definesAssocType (Map.elems tab) of + Just (cd,_) -> return cd + Nothing -> phasefail ("No class found which defines the associated " ++ + "type synonym " ++ showPpr id) + where definesAssocType (cd,_) = + id `elem` map fst (class_tsigs cd) + +insertKind :: TypeVarId -> Kind -> ST () +insertKind id k = + do tab <- gets typeVarKindMap + case Map.insertLookup id k tab of + (Nothing, tab') -> + modify (\s -> s { typeVarKindMap = tab' }) + (Just k', _) | k /= k' -> + phasefail ("Cannot insert kind (" ++ showPpr k ++ + ") for type variable `" ++ showPpr id + ++ "': type variable already defined with different " + ++ "kind (" ++ showPpr k' ++ ")") + _ -> return () + +kindOfTypeVarId :: TypeVarId -> ST Kind +kindOfTypeVarId = lookUp typeVarKindMap + +kindAssocs :: ST [(TypeVarId, Kind)] +kindAssocs = + do tab <- gets typeVarKindMap + return $ Map.assocs tab + + + +------------------------------------------------------------------------------ +-- Building the symtab + +{- + +buildSymtab builds the symbol table according to the "Typing rules for +declarations" (Figure 3, ICFP draft). The difficulty here is the +recursive definition of the instance environment. + +(1) Insert class declarations and signature of associated type + synonyms (rule cls). We do not check the premise of the rule + and we do not enter the method signature into the symbol table. + Class declarations are sorted topologically prior to insertion. + +(2) Insert instance declarations, order does not matter (rule inst). + We do not check any premises of this rule. + +(3) Check the first premise of (rule inst), i.e. the well-formedness + of associated type synonyms definitions. Enter the definition + of the associated type synonym into the symbol table. + +(4) Check the premise of (rule cls), i.e. the well-formedness of method + signatures. Enter the signature into the symbol table. + +That's all we can do here. (rule val) and the unchecked premises of +(rule inst) are checked later. + +-} +buildSymtab :: Program -> IO Symtab +buildSymtab (Program typeDefs classDecs classInsts binds) = + runST emptySymtab build + where + build = + do --insertBuiltins + mapM insertTypeDef typeDefs + let orderedClasses = orderClasses classDecs + mapM insertClass orderedClasses + mapM insertInstance classInsts + get + +insertTypeDef :: TypeDef -> ST () +insertTypeDef td = + modify (\s -> s { typeDefMap = + Map.insert (tydef_name td) td (typeDefMap s) }) + +orderClasses classDecs = + let groups = getBindGroups classDecs class_name classDeps + (cyclic, acyclic) = List.partition isCyclic groups + in if not (null cyclic) + then phasefail ("cyclic class hierarchy: " ++ + show (map (ppr . class_name) (head groups))) + else concat acyclic + where classDeps cd = map cc_name $ class_constraints cd + isCyclic group = length group >= 2 + +insertClass :: ClassDec -> ST () +insertClass cd = + modify (\s -> s { classMap = Map.insert (class_name cd) (cd, []) + (classMap s), + assocTypeSigMap = foldr insertTuple (assocTypeSigMap s) + (class_tsigs cd) }) + + +insertInstance :: ClassInst -> ST () +insertInstance ci = + modify addInstance + where addInstance s = + let m = classMap s in + case Map.lookup (inst_class ci) m of + Nothing -> panic ("No such class: " ++ showPpr (inst_class ci)) + Just (cdec, insts) -> + s { classMap = Map.insert (inst_class ci) + (cdec, ci:insts) m} + + +insertTuple :: Ord k => (k, a) -> Map.Map k (k,a) -> Map.Map k (k,a) +insertTuple t@(k,v) = Map.insert k t + addfile ./SyntaxTransformation.hs hunk ./SyntaxTransformation.hs 1 +{-# OPTIONS -fglasgow-exts #-} +-- ^ for pattern guards +-- +-- Copyright (c) 2005 Gabriele Keller (keller@cse.unsw.edu.au) +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- +-- +-- + + +module SyntaxTransformation where + +import ParseSyntax +import qualified AbstractSyntax as AS +import Pretty +import Error +import UniqIdents hiding (TypeVarId, TypeId, DataId, ClassId, + AssocTypeId, MethodId, ValId) +import qualified Builtins + +-- H98 libs +import Monad (liftM, mapM, filterM) +import qualified List +import Maybe (mapMaybe) + +import qualified Data.Set as Set + + + +transform :: Program -> AS.Program +transform p = runNA (rw_programm p) + +-- Paper & Impl: +-- --------------- +-- prg ::= [cdecs] ";" [tyinst] ";" [bind] +-- +rw_programm:: Program -> NA AS.Program +rw_programm (Program typedefs classdecs classinsts binds) = + do --addBuiltIns + -- add forward declarations (but only those which are really needed) + mapM defineTypeDef typedefs + mapM defineClass classdecs + mapM defineToplevelFunction binds + typedefs' <- rw_typedefs typedefs + classdecs' <- rw_classdecs classdecs + classinsts' <- mapM rw_classinst classinsts + binds' <- mapM rw_toplevelBind binds + return (AS.Program typedefs' classdecs' classinsts' binds') + where + addBuiltIns = + do mapM (\ (x,y) -> defineDataCon x y) Builtins.dataConstructors + mapM defineTypeCon Builtins.typeConstructors + defineTypeDef (TypeDef i _ _) = defineTypeCon i + defineClass (ClassDec name _ _ tsigs valsigs) = + do UniqIdents.defineClass name + mapM (\ (id, _) -> defineAssocTypeCon id) tsigs + defineToplevelFunction (ValBind fn _ _ _) = defineValVar fn + +rw_typedefs:: [TypeDef] -> NA [AS.TypeDef] +rw_typedefs = mapM rw_typedef + +rw_typedef:: TypeDef -> NA AS.TypeDef +rw_typedef (TypeDef i args talts) = + do args' <- mapM defineTypeVar args + uid <- lookUpTypeCon i + talts' <- mapM rw_talt talts + mapM undefineTypeVar args' + return (AS.TypeDef uid args' talts') + +rw_talt :: (DataConstructor) -> NA AS.DataConstructor +rw_talt (DataConstructor id args) = + do uid <- defineDataCon id (length args) + args' <- mapM rw_type args + return $ AS.DataConstructor uid args' + + +rw_classdecs::[ClassDec] -> NA [AS.ClassDec] +rw_classdecs = mapM rw_classdec + +rw_classdec:: ClassDec -> NA AS.ClassDec +rw_classdec (ClassDec name param constrs tsigs vsigs) = + do uid <- lookUpClass name + param' <- defineTypeVar param + constrs' <- mapM rw_classConstraint constrs + tsigs' <- mapM rw_tsig tsigs + vsigs' <- mapM rw_vsig vsigs + undefineTypeVar param' + return $ AS.ClassDec uid param' constrs' tsigs' vsigs' + +rw_tsig :: TSig -> NA AS.TSig +rw_tsig (id, []) = phasefail "invalid declaration of associated type synonym: \ + \no arguments specified" +rw_tsig (id, t:ts) = + do uid <- lookUpAssocTypeCon id + t' <- lookUpTypeVar t + ts' <- mapM defineTypeVar ts + mapM undefineTypeVar ts' + return (uid, t':ts') + +rw_vsig:: VSig -> NA AS.VSig +rw_vsig (i, t) = + do uid <- defineMethod i + t' <- rw_typeScheme t + return (uid, t') + + +-- Paper +-- ------ +-- classinst ::= "instance" constrScheme "where" atype ";" bind +-- +-- Impl +-- ------ +-- classinst ::= "instance" constrScheme "where" atype ";" [bind] +-- +rw_classinst:: ClassInst -> NA AS.ClassInst +rw_classinst (ClassInst name param constrs tyBind valBinds) = + do let vars = Set.toList $ freeTypeVars param + vars' <- mapM defineTypeVar vars + constrs' <- mapM rw_constraint constrs + param' <- rw_type param + uid <- lookUpClass name + tyBind' <- rw_assocTypeBind tyBind + valBinds' <- rw_classBinds valBinds + mapM undefineTypeVar vars' + return (AS.ClassInst uid param' constrs' tyBind' valBinds') + +rw_classBinds:: [MethodBind] -> NA [AS.MethodBind] +rw_classBinds = mapM rw_classBind + where rw_classBind :: MethodBind -> NA AS.MethodBind + rw_classBind (MethodBind id params exp) = + do uid <- lookUpMethod id + enterBlock + params' <- mapM defineValVar params + exp' <- rwExp exp + exitBlock + return (AS.MethodBind uid params' exp') + +rw_classConstraint :: ClassConstraint -> NA AS.ClassConstraint +rw_classConstraint cc = + do AS.CC cc' <- rw_constraint (CC cc) + return cc' + +rw_constraint:: Constraint -> NA AS.Constraint +rw_constraint (CC (ClassConstraint i t)) = + do uid <- lookUpClass i + t' <- rw_type t + return (AS.CC (AS.ClassConstraint uid t')) +rw_constraint (EC (EqConstraint (AssocType id params) t2)) = + do uid <- lookUpAssocTypeCon id + params' <- mapM rw_type params + t2' <- rw_type t2 + return (AS.EC (AS.EqConstraint (AS.AssocType uid params') t2')) + +rw_assocTypeBind :: AssocTypeBind -> NA AS.AssocTypeBind +rw_assocTypeBind (AssocTypeBind id index params ty) = + do uid <- lookUpAssocTypeCon id + index' <- rw_type index + params' <- mapM defineTypeVar params + ty' <- rw_type ty + mapM undefineTypeVar params' + return (AS.AssocTypeBind uid index' params' ty') + +rw_typeScheme :: TypeScheme -> NA AS.TypeScheme +rw_typeScheme (TypeScheme [] qtype) = + do undef <- undefinedTypeVars qtype + let free = case qtype of + UnconstrainedType _ -> undef + ConstrainedType _ t -> + undef `List.intersect` freeTypeVarsList t + free' <- mapM defineTypeVar free + qtype' <- rw_qualifiedType qtype + mapM undefineTypeVar free' + return (AS.TypeScheme free' qtype') + +rw_typeScheme _ = panic "TypeScheme with non-empty list of quantified \ + \variables produced by the parser" + +rw_qualifiedType :: QualifiedType -> NA AS.QualifiedType +rw_qualifiedType (ConstrainedType constrs t) = + do constrs' <- mapM rw_constraint constrs + t' <- rw_type t + return (AS.ConstrainedType constrs' t') + +rw_qualifiedType (UnconstrainedType t) = + do t' <- rw_type t + return (AS.UnconstrainedType t') + +-- rw_type: +-- * rewrite type +-- +rw_type:: Type -> NA AS.Type +rw_type (TyVar v) = + do uid <- lookUpTypeVar v + return $ AS.TyVar uid + +-- we have to check if type constructor at the top of the +-- application chain is a assoc type, and restructure it +-- if necessary +rw_type t@(TyApp t1 t2) = + do res <- isAT t + case res of + Nothing -> + do t1' <- rw_type t1 + t2' <- rw_type t2 + return (AS.TyApp t1' t2') + Just (_, []) -> + phasefail "Renamer" "AT not applied to anything" + Just (id, args') -> + let args = reverse args' + assoc = AS.AssocType id args + in return (AS.TyAssoc assoc) + where + isAT (TyConstruct tc) = + do b <- isAssocTypeCon tc + if b + then do uid <- lookUpAssocTypeCon tc + return (Just (uid, [])) + else return Nothing + isAT (TyApp t1 t2) = + do at <- isAT t1 + case at of + Nothing -> return Nothing + Just (tc, args) -> do t2' <- rw_type t2 + return (Just (tc, t2':args)) + isAT _ = return Nothing + + +rw_type (TyConstruct id) = + do uid <- lookUpTypeCon id + return (AS.TyConstruct uid) + + +rwExp :: Exp -> NA AS.Exp +rwExp (Var id) = + do uid <- lookUpValVar id + return (AS.Var uid) + +rwExp (Num i) = return (AS.Num i) + +rwExp (Prim o es) = + do rn_es <- mapM rwExp es + return (AS.Prim o rn_es) + +rwExp (Con tg []) = + do (tg', arity) <- lookUpDataCon tg + vs <- mapM freshValVar (take arity $ repeat "v") + let con = AS.Con tg' (map AS.Var vs) + if arity == 0 + then return con + else return (AS.Lam vs con) + + +rwExp (Con tg _) = + panic "parser should not produce constructor expression with non-empty \ + \expression list" + +rwExp (Lam vs e) = + do enterBlock + vs' <- mapM defineValVar vs + e' <- rwExp e + exitBlock + return (AS.Lam vs' e') + +rwExp (If e e1 e2) = + do e' <- rwExp e + e1' <- rwExp e1 + e2' <- rwExp e2 + return (AS.If e' e1' e2') + +rwExp (Case e alts) = + do e' <- rwExp e + alts' <- mapM rwAlt alts + return (AS.Case e' alts') + where + rwAlt (Alt tg ids e) = + do (tg', arity) <- lookUpDataCon tg + if arity /= length ids + then phasefail ("wrong number of arguments for data " ++ + "constructor `" ++ showPpr tg ++ "' in case " + ++ " expression") + else return () + enterBlock + ids' <- mapM defineValVar ids + e' <- rwExp e + exitBlock + return (AS.Alt tg' ids' e') + +rwExp (App (App (Var v) e1) e2) + | (Just op) <- Builtins.strToPrimOp v, Builtins.isBinPrimOp op = + do e1' <- rwExp e1 + e2' <- rwExp e2 + return (AS.Prim op [e1',e2']) + +rwExp (App e1 e2) = + do e1' <- rwExp e1 + e2' <- rwExp e2 + return (AS.App e1' e2') + +rwExp (Let binds e) = + do triples <- mapM rw_bind binds + enterBlock + names <- mapM defineBind binds + e' <- rwExp e + exitBlock + let binds' = map mkBind (zip names triples) + return (AS.Let binds' e') + +rwExp (Letrec binds e) = + do enterBlock + names <- mapM defineBind binds + triples <- mapM rw_bind binds + e' <- rwExp e + exitBlock + let binds' = map mkBind (zip names triples) + return (AS.Letrec binds' e') + +type BindTriple = (Maybe AS.TypeScheme, [AS.ValId], AS.Exp) + +mkBind :: (AS.ValId, BindTriple) -> AS.ValBind +mkBind (name, (ty, params, e)) = AS.ValBind name ty params e + +defineBind :: ValBind -> NA AS.ValId +defineBind (ValBind f _ _ _) = defineValVar f + +rw_bind :: ValBind -> NA BindTriple +rw_bind (ValBind _ Nothing args e) = + do enterBlock + args' <- mapM defineValVar args + e' <- rwExp e + exitBlock + return (Nothing, args', e') +rw_bind (ValBind _ (Just ty) args e) = + do enterBlock + args' <- mapM defineValVar args + e' <- rwExp e + exitBlock + ty' <- rw_typeScheme ty + return ((Just ty'), args', e') + +rw_toplevelBind b@(ValBind f ty params e) = + do f' <- lookUpValVar f + triple <- rw_bind b + return (mkBind (f', triple)) + +undefinedTypeVars ty = filterM (liftM not . isDefinedTypeVar) + (freeTypeVarsList ty) addfile ./TyCheck.hs hunk ./TyCheck.hs 1 +-- +-- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- + +module TyCheck where +{- +import Syntax +import Ident +import Type +import Rename +import PrimOp +-} + +tycheck = id addfile ./TyInfer.hs hunk ./TyInfer.hs 1 - +-- +-- Copyright (c) 2005 Gabriele Keller (keller@cse.unsw.edu.au) +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- + + +-- TODO: +-- - if constant predicate in constraints: this is ignored atm, instead of +-- rejecting the program +-- - type annotations atm completely ignored +-- - mutually recursive functions are not handled properly: there is no +-- dependency analysis and they are just typed in the order they appear +-- +-- +-- + +module TyInfer where +{- +import Syntax +import Ident +import Type +import Maybe (isNothing) +import Rename +import PrimOp +import Pretty +import Text.PrettyPrint +import Error + +-- hierarchical libs +import Data.Map (Map, empty, insert, lookup, fromList,delete, + toList, insertWith, toAscList) +import Data.Set (Set, emptySet, unitSet, mkSet, setToList, union, + intersection, toAscList, fromAscList, + unionManySets, minusSet, delFromSet, addToSet, + fromList, difference) + + +import Debug.Trace (trace) + +type TypeMap = Map Id Type + + +type TypeSubs = Map Id Type + + + +-- +type Preds = Set Constraint -- set already takes care of + -- duplicated entries +type ConstraintSchemes = [ConstraintScheme] -- constraint schemes should be unique + + + +-- Typecheck monad +-- --------------- +-- + +data TCState = TCState { + gamma :: TypeMap, -- type environment + uniqCnt :: Int, -- unique name supply + objsTC :: ObjectMap, -- object map passed in + -- from renamer + subsMap :: TypeSubs, + theta :: Preds, -- set of required + -- predicates (theta) + u :: Preds, -- pending equlity + -- constraints (u) + thetaP :: ConstraintSchemes -- set of given + -- predicates + } + + +newtype TC r = TC (TCState -> (r, TCState)) + +unTC:: TC r -> TCState -> (r, TCState) +unTC (TC m) = m + + +debug = False -- True +dTrace s res = if debug then (trace s res) else res + + +liftM:: (a-> b) -> TC(a) -> TC (b) +liftM f mval= + do + v <- mval + return (f v) +-- +-- + +showConstraint:: Constraint -> String +showConstraint cs = + (render (ppr cs)) ++ "\n" + + +showConstraintScheme cs = + (render (ppr cs)) ++ "\n" + + +-- Operations on Theta +-- + +extendTheta:: Constraint -> TC() +extendTheta cn = TC $ \s -> + ((), s {theta = addToSet (theta s) cn}) + + + + +-- Operations on the constrain scheme +-- +addThetaPConstr:: ConstraintScheme -> TC () +addThetaPConstr cn = TC $ \s -> + ((), s {thetaP = cn:(thetaP s)}) + + +dumpThetaP:: TC [ConstraintScheme] +dumpThetaP = TC $ \s -> + (thetaP s , s) + +-- Given an associated type (at ts) try and find rule +-- cs => (r_at r_ts) = mt with (at ts) ~s~ (r_at r_ts) +-- return (s r_ts, s mt) + +findMatchThetaP:: (Id, [Type]) -> TC Type +findMatchThetaP (at, ts) = + do + cs <- dumpThetaP + check_all cs + where + check_all [] = return (TySyn at ts) + check_all (c:cs) = + do + trc <- tryRule c + case trc of + Nothing -> check_all cs + Just r -> return r + tryRule cscheme = + do + (c, cs) <- end_Constraint cscheme + case c of + EqCons mt1 mt2 -> + do + let msubst = match mt1 (UserCon at, ts) + case msubst of + Nothing -> return (Nothing) + Just subst -> return (Just (subst mt2)) + SimpleCons tc t -> return Nothing + +liftC:: Subst -> CSubst +liftC s (SimpleCons tc t) = SimpleCons tc (s t) +liftC s (EqCons t1 t2) = EqCons (s t1) (s t2) + + +-- Operations on theta and u +-- +addToThetaOrU:: Constraint -> TC () +addToThetaOrU c@(SimpleCons tc (TyVarTy i)) = TC $ \s -> + ((), s {theta = addToSet (theta s) c}) +addToThetaOrU c@(EqCons t1 t2) = TC $ \s -> + ((), s {u = addToSet (u s) c}) + + +dumpTheta:: TC [Constraint] +dumpTheta = TC $ \s -> + (setToList (theta s) , s) + +dumpU:: TC [Constraint] +dumpU = TC $ \s -> + (setToList (u s) , s) + + +showU:: TC String +showU = + do + uList <- dumpU + let strList = map (render.ppr) uList + let strList' = map (\s -> " " ++ s ++ "\n") strList + return ("U:\n" ++ (concat strList')) + +replaceTheta:: [Constraint] -> TC() +replaceTheta newpreds = TC $ \s -> + ((),s {theta = Data.Set.fromList newpreds}) + +replaceU:: [Constraint] -> TC() +replaceU newpreds = TC $ \s -> + ((),s {u = Data.Set.fromList newpreds}) + +showTheta:: TC (String) +showTheta = + do + uList <- dumpTheta + let strList = map (render.ppr) uList + let strList' = map (\s -> " " ++ s ++ "\n") strList + return ("Theta:\n" ++ (concat strList')) + + +-- +-- Ops for the substitution +-- + +-- apply variable substitution only once +applyVarSubst:: Id -> TC (Type) +applyVarSubst i = TC $ \s -> + case Data.Map.lookup i (subsMap s) of + Nothing -> (TyVarTy i, s) + Just ty -> (ty, s) + + +applyConstrSubst:: Constraint -> TC Constraint +applyConstrSubst (SimpleCons c t) = + do + t' <- applyTySubst t + return (SimpleCons c t') +applyConstrSubst (EqCons t1 t2) = + do + t1' <- applyTySubst t1 + t2' <- applyTySubst t2 + return (EqCons t1' t2') + +applyTySubst:: Type -> TC (Type) +applyTySubst t@(TyVarTy tv) = + do + t' <- applyVarSubst tv + t'' <- if t' == t then return t' + else applyTySubst t' + return (t'') + +applyTySubst (FunTy t1 t2) = + do + t1' <- applyTySubst t1 + t2' <- applyTySubst t2 + return (FunTy t1' t2') +applyTySubst (ForallTy tv t) = + do + rest <- removeTmpEnv tv + t' <- applyTySubst t + restoreEnv rest + return (ForallTy tv t') + +applyTySubst (TyApp t1 t2) = + do + t1' <- applyTySubst t1 + t2' <- applyTySubst t2 + return (TyApp t1' t2') +applyTySubst tc@(TyConstr _) = return tc +applyTySubst (ConstrTy (SimpleCons tc t1) t2) = + do + t1' <- applyTySubst t1 + t2' <- applyTySubst t2 + return (ConstrTy (SimpleCons tc t1') t2') +applyTySubst (ConstrTy (EqCons t1 t2) t3) = + do + t1' <- applyTySubst t1 + t2' <- applyTySubst t2 + t3' <- applyTySubst t3 + return (ConstrTy (EqCons t1' t2') t3') + +applyTySubst (TySyn i ts) = + do + ts' <- mapM applyTySubst ts + return (TySyn i ts') + +addSubst:: Id -> Type -> TC () +addSubst fromId toType = TC $ \s -> + ((), s {subsMap = insert fromId toType (subsMap s)}) + + + +showSubs:: TC (String) +showSubs = TC $ \s -> + ((++) "Substs: \n" $ concat $ map toMapStr (strList s), s) + where + mapList s = toList (subsMap s) + strList s = map (\(i,s) -> ((render $ ppr i), (render $ppr s))) (mapList s) + toMapStr (s1, s2) = " " ++ s1 ++ " |-> " ++ s2 ++ "\n" + + +newId :: TC Id +newId = TC $ \s -> + let + cnt = uniqCnt s + newId = mkId ("gen_tvar" ++ "'" ++ (show cnt)) + in (newId, s {uniqCnt = cnt + 1}) + + +lookupEnv:: Id -> TC (Type) +lookupEnv id = TC $ \s -> + case Data.Map.lookup id (gamma s) of + Nothing -> phasefail "TyInfer:" ("no type in env" ++ (show id)) + Just ty -> (ty, s) + + + +addToEnv:: Id -> Type -> TC () +addToEnv id ty = TC $ \s -> + ((), s {gamma = insert id ty (gamma s)}) + +-- remove from environment temporarily, +-- restoreEnv will add binding to environment again +removeTmpEnv:: Id -> TC (Maybe (Id, Type)) +removeTmpEnv i = TC $ \s -> + case Data.Map.lookup i (gamma s) of + Nothing -> (Nothing, s) + Just t -> (Just (i,t), s {gamma = delete i (gamma s)}) + +restoreEnv:: (Maybe (Id, Type)) -> TC () +restoreEnv Nothing = TC $ \s -> ((),s) +restoreEnv (Just (i,t)) = TC $ \s -> + ((), s {gamma = insert i t (gamma s)}) + + +freeVarEnv:: TC (Set TyVar) +freeVarEnv = TC $ \s -> + let types = map snd (Data.Map.toAscList (gamma s)) + freeVars = foldr union emptySet (map freeTyVar types) + in (freeVars, s) + +showEnv:: TC (String) +showEnv = TC $ \s -> + ( (++) "Env: \n" $ concat $ map toMapStr (strList s), s) + where + mapList s = toList (gamma s) + strList s = map (\(i,s) -> ((render $ ppr i), (render $ppr s))) (mapList s) + toMapStr (s1, s2) = " " ++ s1 ++ " |-> " ++ s2 ++ "\n" + + +instance Monad TC where + return r = TC $ \s -> (r, s) + m >>= n = TC $ \s -> let (r, s') = unTC m s in unTC (n r) s' + +-- run a name analysis in a fresh NA environment +-- + +runTC :: ObjectMap -> TC a -> (a, TypeMap) +runTC ob m = + let (r, s) = unTC m initTCState + in + (r, gamma s) + where + initTCState :: TCState + initTCState = + TCState Data.Map.empty 0 ob Data.Map.empty emptySet emptySet [] + + +-- unifies two skolemised types +-- precon: current substitution has to be applied before trying to unify +-- not sure if we actually need to return the new type +unify:: Type -> Type -> TC () +unify (TyVarTy tv1) t = + do + tv <- addSubst tv1 t + return () + +unify t (TyVarTy tv1) = + do + tv <- addSubst tv1 t + return () + + +unify (FunTy t1 t2) (FunTy t1' t2') = + do + unify t1 t1' + t2_s <- applyTySubst t2 + t2_s' <- applyTySubst t2' + unify t2_s t2_s' + +unify (TyApp t1 t2) (TyApp t1' t2') = + do + unify t1 t1' + t2_s <- applyTySubst t2 + t2_s' <- applyTySubst t2' + unify t2 t2' + +unify (TyConstr tc1) (TyConstr tc2) = + if tc1 == tc2 + then return () + else phasefail "TyInfer:" ("Cannot unify " ++ (show tc1) ++ " and " ++ + (show tc2)) + +unify (ConstrTy _ _) _ = phasefail "TyInfer:" "Unify contr not yet impl" +unify _ (ConstrTy _ _) = phasefail "TyInfer:" "Unify contr not yet impl" + +unify t1 t2 = phasefail "TyInfer:" ("Cannot unify " ++ (show t1) ++ " and " ++ + (show t2)) + + + +-- +-- +-- Look for Phi t Nothing Nothing and try to match SimpleCons tc t to +-- constraint +-- TODO: for assoc type: handle eq constraints, that is Phi t1 (Just t2) + +match:: Type -> (TyCon, [Type]) -> Maybe (Type -> Type) +match (FunTy _ _) _ = Nothing +match con (at, ts) | at' /= at = Nothing + | otherwise = matchTypes ts' ts + where + (at', ts') = splitConstr con + splitConstr (TyApp (TyConstr tc) t) = (tc, [t]) + splitConstr (TyApp t1 t2) = + let (tc,ts) = splitConstr t2 + in (tc, t1:ts) + splitConstr t = phasefail "TyInfer:" $ "match: Malformed type function head :" ++ show t + +matchTypes :: [Type] -> [Type] -> Maybe Subst +matchTypes [] [] = Just id +matchTypes (pat:pats) (t:ts) = + do + subst1 <- matchType pat t + subst2 <- matchTypes pats ts + return $ subst1 . subst2 +matchTypes _ _ = + phasefail "TyInfer:" "matchTypes: ATS used at different arities" + + +matchType:: Type -> Type -> Maybe (Type -> Type) +matchType (TyConstr tc1) (TyConstr tc2) + | tc1 == tc2 = Just id + | otherwise = Nothing +matchType (TyVarTy tv1) t = Just (tv1 |-> t) +matchType (FunTy t1 t2) (FunTy t1' t2') = + do + subs1 <- matchType t1 t1' + subs2 <- matchType t2 t2' + return (subs2 .subs1) +matchType (TyApp t1 t2) (TyApp t1' t2') = + do + subs1 <- matchType t1 t1' + subs2 <- matchType t2 t2' + return (subs2 .subs1) +matchType _ _ = Nothing + +type Subst = Type -> Type +type CSubst = Constraint -> Constraint + +-- A single mapping +-- +(|->) :: TyVar -> Type -> Subst +(a |-> t) t'@(TyConstr _) = t' +(a |-> t) t'@(TyVarTy b ) | a == b = t + | otherwise = t' +(a |-> t) (TyApp t1 t2) = TyApp ((a |-> t) t1) ((a |-> t) t2) +(a |-> t) (FunTy t1 t2) = FunTy ((a |-> t) t1) ((a |-> t) t2) + + +-- Infer type of expression: returns inferred type and expression where +-- type annotations have been added to every binding +tyInferExpr:: Exp -> TC (Exp, Type) +tyInferExpr e@(Var i) = + do + t <- lookupEnv i + t' <- forallElimType t + dTrace ("*tyInferExpr*" ++ (render $ ppr i) ++ "::" ++ + (render $ ppr t')++ "*\n") + return (e, t') + +tyInferExpr e@(Num _) = + return (e, TyConstr IntCon) + + +tyInferExpr (Prim op exprs) = + do + exprTys' <- mapM tyInferExpr exprs + ts <- mapM (uncurry unify) (zip (map snd exprTys') (argTypes (typeOfPrimOp op))) + return (Prim op (map fst exprTys'), resultType (typeOfPrimOp op)) + where + resultType t@(TyConstr _) = t + resultType (FunTy _ t) = resultType t + argTypes t@(TyConstr _) = [] + argTypes (FunTy t ts) = t : (argTypes ts) + + +tyInferExpr e@(Con tag []) + | tag == unitTag = return (e, TyConstr UnitCon) + | tag == falseTag = return (e, TyConstr BoolCon) + | tag == trueTag = return (e, TyConstr BoolCon) + +tyInferExpr e@(Con pairTag [e1, e2]) = + do + (e1', t1) <- tyInferExpr e1 + (e2', t2) <- tyInferExpr e2 + let pairType = (TyApp (TyApp (TyConstr PairCon) t1) t2) + return (Con pairTag [e1', e2'], pairType) + +tyInferExpr e@(Con tg@(Tag i _ _) args) = + do + t <- case args of + [] -> lookupEnv i + _ -> (liftM snd) $ tyInferExpr (foldr App (Con tg []) args) + t' <- forallElimType t + return (e,t') + +tyInferExpr (App ex1 ex2) = + do + (ex1', t1) <- tyInferExpr ex1 + (ex2', t2) <- tyInferExpr ex2 + newt <- newId + t1' <- applyTySubst t1 + let ft = FunTy t2 (TyVarTy newt) + addToThetaOrU (EqCons t1' ft) + new_u <- unifyC + replaceU new_u + newt' <- applyTySubst (TyVarTy newt) + return (App ex1' ex2', newt') + + +tyInferExpr (Lam ids expr) = + do + types <- mapM (\i -> newId) ids + let typePairs = zip ids types + mapM (\(i,t) -> addToEnv i (TyVarTy t)) typePairs + (e', t') <- tyInferExpr expr + types' <- mapM applyVarSubst types + let finalType = foldr FunTy t' (map TyVarTy types) + mapM removeTmpEnv types + return (Lam ids e', finalType) + +tyInferExpr (If ex1 ex2 ex3) = + do + (ex1', t1) <- tyInferExpr ex1 + unify t1 (TyConstr BoolCon) + (ex2', t2) <- tyInferExpr ex2 + (ex3', t3) <- tyInferExpr ex3 + t2' <- applyTySubst t2 + unify t2' t3 + -- todo: check: apply substitution to both branches? + t' <- applyTySubst t2 + return (If ex1' ex2' ex3', t') + +tyInferExpr (Let bnds exp) = + do + bnds' <- mapM tyInferBnd bnds + (exp', ty) <- tyInferExpr exp + mapM (\(Bind i _ _ _) -> removeTmpEnv i) bnds' + return (Let bnds' exp', ty) + where + tyInferBnd l@(Bind i Nothing [] exp) = + do + (exp', ty) <- tyInferExpr exp + addToEnv i ty + return (Bind i (Just ty) [] exp') + tyInferBnd bnd = + phasefail "TyInfer:" + ("let-expr with arguments: " ++ show bnd) + + +tyInferExpr (Letrec bnds exp) = + do + mapM addBndToEnv bnds + bndTy <- mapM tyInferRecBnd bnds + (exp', ty) <- tyInferExpr exp + mapM (\(Bind f _ _ _) -> removeTmpEnv f) bnds + return (Let bnds exp', ty) + +tyInferExpr e = phasefail "TyInfer:" ("Not yet implemented: " ++ + show e) + +-- +-- * infer type of function +-- * simplify theta and U +-- * add the relevant constraints of theta and U to inferred type +-- and generalise it +tyInferRecBnd (Bind f Nothing args exp) = + do + -- add dummy type vars to env for arguments + -- and function + argTys <- mapM addNewTvToEnv args + fty <- addNewTvToEnv f + (exp', ty) <- tyInferExpr exp + ftype <- lookupEnv f + addToThetaOrU (EqCons ftype (mkFunTy ty argTys)) + new_u <- unifyC + replaceU new_u + let bnd = (Bind f Nothing args exp') + mapM (\(TyVarTy t) -> removeTmpEnv t)(fty:argTys) + mapM removeTmpEnv args + bnd' <- addTypeToBnd bnd + return bnd' + where + mkFunTy resT argts = foldr FunTy resT argts + +addBndToEnv (Bind f _ _ _) = + do nt <- newId + addToEnv f (TyVarTy nt) + +addNewTvToEnv f = + do + tv <- newId + addToEnv f (TyVarTy tv) + return (TyVarTy tv) + + +-- \/ a_i. constr => tau ---> add [b_i/a_i] constr to +-- theta, if simple constraint +-- u, if eq constraint +-- +-- return [b_i/a_i]tau, b_i new +-- todo: change name +-- +forallElimType:: Type -> TC Type +forallElimType t = + do + tvPairs <- mapM mkIdPair ts + let newt = renameVars t' tvPairs + case newt of + (ConstrTy c restT) -> + do addToThetaOrU c + return restT + _ -> + return newt + where + mkIdPair id = + do + newId <- newId + return (id, newId) + + (t', ts) = stripQVars t + + stripQVars (ForallTy tv t) = + let (t', tvs) = stripQVars t + in (t', tv:tvs) + stripQVars t = (t, []) + + + +-- rename ty ts: replace all occurences of map fst ts by +-- the corresponding element of map snd ts +-- +renameVars:: Type -> [(TyVar, TyVar)] -> Type +renameVars t@(TyVarTy tv) ts + | (Just s) <- Prelude.lookup tv ts = TyVarTy s + | True = t +renameVars (FunTy t1 t2) ts = + FunTy (renameVars t1 ts) (renameVars t2 ts) +renameVars (TyApp t1 t2) ts = + TyApp (renameVars t1 ts) (renameVars t2 ts) +renameVars t@(TyConstr tc) _ = + t +renameVars (ConstrTy c t) ts = + ConstrTy (renameVarsConstr c ts) (renameVars t ts) + where + renameVarsConstr (SimpleCons tc t) ts = + SimpleCons tc (renameVars t ts) + renameVarsConstr (EqCons t1 t2) ts = + EqCons (renameVars t1 ts) (renameVars t1 ts) +renameVars (TySyn i tys) ts = + TySyn i (map (\t -> renameVars t ts) tys ) +renameVars _ _ = phasefail "TyInfer:" "Not all quantifiers supposed to be in renamed type" + + + + +addTypeToBnd:: Bind -> TC Bind +addTypeToBnd (Bind f _ args ex) = + do + ty <- lookupEnv f + ty' <- applyTySubst ty + let freeTV = freeTyVar ty' + constrs <- dumpTheta + constrs2 <- mapM applyConstrSubst constrs + replaceTheta constrs2 + simplify + let constrs' = Data.Set.toAscList $ + Data.Set.fromAscList [c | c <- constrs2, containsFreeVar c freeTV] + eqConstrs <- dumpU + eqConstrs' <- mapM applyConstrSubst eqConstrs + let tyC = foldr ConstrTy ty' (constrs') + let freeTV' = freeTyVar tyC + gammaFreeVars <- freeVarEnv + let freeTV'' = difference freeTV' gammaFreeVars + let tyC' = forAllifyType tyC (setToList freeTV'') + addToEnv f tyC' + return (Bind f (Just tyC') args ex) + where + containsFreeVar:: Constraint -> Set TyVar -> Bool + containsFreeVar (SimpleCons tc t) ts = + not (intersection (freeTyVar t) ts == emptySet) + containsFreeVar (EqCons t1 t2) ts2 = + not (intersection (union (freeTyVar t1) (freeTyVar t2)) ts2 == emptySet) + +-- Enter types of built in type constructors into environment +initEnv:: TC () +initEnv = return () + + +-- TODO: handle tsigs +-- +-- enterClassDec:: ClassDec -> TC [()] +enterClassDec (ClassDec phi tsigs vsigs) = + do + mapM addVSig vsigs + where + typeToConstrType:: Type -> PhiConstr -> Type + typeToConstrType t (Phi c Nothing) = ConstrTy c t + typeToConstrType t (Phi c morePhi) = ConstrTy c (typeToConstrType t phi) + + addVSig:: VSig -> TC () + addVSig (VSig i t) = + let t' = (typeToConstrType t phi) + in addToEnv i (forAllifyType t' (setToList (freeTyVar t'))) + + + +enterInst:: ClassInst -> TC () +enterInst (ClassInst cs a bnds) = + do + addThetaPConstr cs + addThetaPConstr aConstr + where + assocToConstr:: AssocType -> ConstraintScheme + assocToConstr (AssocType tc t1 tvars t2) = + Simple $ Phi (EqCons (foldr TyApp t1 (map TyVarTy tvars)) t2) + Nothing + aConstr:: ConstraintScheme + aConstr = forAllifyConstrScheme (assocToConstr a) (forAllVars cs) + + forAllVars (Simple _) = [] + forAllVars (ForallQC tv cs) = tv : (forAllVars cs) + + forAllifyConstrScheme:: ConstraintScheme -> [TyVar] -> ConstraintScheme + forAllifyConstrScheme c ts = foldr ForallQC c ts + + +-- enters type of constructors into environment +tyInferTypeDef:: TypeDef -> TC () +tyInferTypeDef (TypeDef tc args talts) = + do + let resultType = foldl TyApp (TyConstr tc) (map TyVarTy args) + mapM (tyInferTypeAlts resultType args) talts + return () + +tyInferTypeAlts:: Type -> [TyVar] -> (TyCon, [Type]) -> TC () +tyInferTypeAlts resultType typeArgs (tc@(UserCon i), args) = + do + let constrType = foldr FunTy resultType args + let constrType' = forAllifyType constrType typeArgs + addToEnv i constrType' + +elaborate :: (Program, ObjectMap) -> (Program, ObjectMap) +elaborate (Prg tdefs cldecs cinsts bnds, obmap) = + let + tfb bnds = + do + mapM tyInferTypeDef tdefs + --enterBuiltIns + mapM enterClassDec cldecs + mapM enterInst cinsts + bnds' <- mapM tyInferRecBnd bnds + constrs <- dumpTheta + constrs' <- mapM applyConstrSubst constrs + replaceTheta constrs' + simplify + -- debug stuff + uStr <- showU + mapStr <- showSubs + envStr <- showEnv + thetaStr <- showTheta + -- bnds'' <- mapM addTypeToBnd bnds' + --trace o + -- ("Final\n========\n" ++ mapStr ++ uStr ++ envStr ++ thetaStr) + return (bnds') + bnds' = runTC obmap (tfb bnds) + in (Prg tdefs cldecs cinsts (fst bnds'), obmap) + + +-- Enter some built in type constructors and functions in gamma +enterBuiltIns:: TC() +enterBuiltIns = + do + id1 <- newId + let listTy = TyConstr (UserCon (mkId "List")) + let toListTy = ForallTy id1 (FunTy (TyVarTy id1) + (TyApp listTy (TyVarTy id1))) + addToEnv (mkId "mkList") toListTy + id2 <- newId + id3 <- newId + let id2T = TyVarTy id2 + let id3T = TyVarTy id3 + let ft = FunTy (FunTy id2T (FunTy id3T id3T)) + (FunTy id3T (FunTy (TyApp listTy id2T) id3T)) + let faFt = ForallTy id2 (ForallTy id3 ft) + addToEnv (mkId "foldr") faFt + return () + + +-- Get rid of derivable constraints in theta: +-- +-- +-- 1) get all constraints in constraint scheme list +-- 2) compute set of 'end constraints' and associated remainders +-- (end_constraints) +-- 3) take constraint from theta and try to match it to end constraint, +-- and try to derive associated remainders +-- 4) Continue is empty or cannot be simplified further + + +-- The phiconstraint returned in the list always have the form +-- Phi (tc t) mt Nothing and therefore always correspond to +-- a constraint of the form SimpleCon tc t or EqCons tc [t] mt +-- +-- +end_Constraint:: ConstraintScheme -> TC (Constraint, [Constraint]) +end_Constraint cs = + do p' <- forallElimCon p tvs + return (find_endcon p') + where + (tvs, p) = stripForallVars cs + p' = forallElimCon p tvs + find_endcon:: PhiConstr -> (Constraint, [Constraint]) + find_endcon p@(Phi c Nothing) = (c, []) + find_endcon (Phi c (Just p)) = + let (c', cs) = find_endcon p + in (c', (c:cs)) + + forallElimCon (Phi t@(SimpleCons tc t1) Nothing) tvs = + do t1' <- forallElimType (forAllifyType t1 tvs) + return (Phi (SimpleCons tc t1') Nothing) + forallElimCon (Phi t@(SimpleCons tc t1) (Just p)) tvs = + do t1' <- forallElimType (forAllifyType t1 tvs) + p' <- forallElimCon p tvs + return (Phi (SimpleCons tc t1') (Just p')) + forallElimCon (Phi (EqCons t1 t2) Nothing ) tvs = + do + t1' <- forallElimType (forAllifyType t1 tvs) + t2' <- forallElimType (forAllifyType t2 tvs) + return (Phi (EqCons t1' t2') Nothing) + forallElimCon _ _ = + phasefail "TyInfer:" "end_Constraint: eq constraint should be at the end of the chain??" + stripForallVars (Simple p) = ([], p) + stripForallVars (ForallQC tv cs) = + let (tvs, p) = stripForallVars cs + in (tv:tvs, p) + + + +-- Tries to match a constraint c to the conclusion c' of a constraint sequence +-- of the form c1 & c2 ... => c'. If match successful, returns instantiated +-- cis +-- +simp_singleCon:: Constraint -> (Constraint, [Constraint]) -> Maybe [Constraint] +simp_singleCon (SimpleCons tc1 t1) ((SimpleCons tc2 t2), cs) + | tc1 == tc2 = case msubst of + Nothing -> Nothing + Just sub -> Just (map (consTypeMap sub) cs) + | otherwise = Nothing + where + msubst = matchType t2 t1 + consTypeMap f (SimpleCons tc t) = SimpleCons tc (f t) + consTypeMap f (EqCons t1 t2) = EqCons (f t1) (f t2) +-- TODO: check what kind of simplifications possible for EQ +simp_singleCon c1 c2 = Nothing + + +simp_constraints:: + [Constraint] -> [(Constraint, [Constraint])] -> ([Constraint], Bool) +simp_constraints [] gcons = ([], False) +simp_constraints rs [] = (rs, False) +simp_constraints rs@(rc:rcons) gs@(_:rgs) = + case simp_singleCon' rc gs of + Nothing -> let (cs, f) = (simp_constraints rcons gs) + in (rc:cs, f) + Just cons -> let (cs, _) = simp_constraints (cons ++ rcons) gs + in (cs, True) + where + simp_singleCon' r [] = Nothing + simp_singleCon' r (g:gs) = + case simp_singleCon r g of + Nothing -> simp_singleCon' r gs + mcons -> mcons + +-- iterates over given constraint and class def set until constraints cannot +-- be simplified any further +simp_constraints_it:: + [Constraint] -> [(Constraint, [Constraint])] -> [Constraint] +simp_constraints_it rcs gcs = + case simp_constraints rcs gcs of + (cs, True) -> simp_constraints_it cs gcs + (cs, False) -> cs + + +-- Simplify global constraints +-- +-- if there are still ground contraints in the simplified set, it means we +-- cannot find an instance for this class, and the program does not type check +simplify:: TC () +simplify = + do + constraints <- dumpTheta + thetaP <- dumpThetaP + gconstraints <- mapM end_Constraint thetaP + let simp_constraints = + simp_constraints_it constraints gconstraints + let unsolvable = or $ map isGroundConstraint simp_constraints + if unsolvable + then phasefail "TyInfer:" $ + "Cannot derive instance " ++ (render $ ppr simp_constraints) + else do + replaceTheta simp_constraints + return () + where + isGroundConstraint:: Constraint -> Bool + isGroundConstraint (SimpleCons tc t) = + (freeTyVar t) == emptySet + isGroundConstraint (EqCons t1 t2) = + ((freeTyVar t1) == emptySet) && + ((freeTyVar t2) == emptySet) + +norm :: Type -> TC Type +norm c@(TyConstr _) = return c -- con_R +norm v@(TyVarTy _) = return v -- var_R +norm (TyApp t1 t2) = -- app_R + do + ty1 <- norm t1 + ty2 <- norm t2 + return $ TyApp ty1 ty2 + +norm (FunTy t1 t2) = + do + ty1 <- norm t1 + ty2 <- norm t2 + return $ FunTy ty1 ty2 + + + +norm ty@(TySyn i ts) = + do + normTs <- mapM norm ts + i @@ normTs -- assoc type appl + where -- & red_R + at @@ ts = + do + ty' <- findMatchThetaP (at, ts) + if ty == ty' then return ty -- no change + else norm ty' -- continue + + +norm ty = phasefail "TyInfer:" $ "norm:" ++ (render $ ppr ty) + + +-- Unification +-- - + +-- A single rewrite step on one equality constraints. +-- +-- thetaP :: [Scheme] +-- tau1 :: Type +-- tau2 :: Type +-- --- +-- u :: [Con] +-- s :: Subst +-- +unifyOne :: (Type, Type) -> TC (Maybe ([Constraint])) +unifyOne (t1, t2) + | t1 == t2 = return $ Just [] +unifyOne (t@(TyVarTy v), t2) = + do + t' <- applyTySubst t + t2' <- applyTySubst t2 + case t' of + (TyVarTy v') -> + if (notElem v' (setToList (freeTyVar t2'))) + then + do + addSubst v' t2' + return $ Just [] + else phasefail "TyInfer:" "unifyOne: rec occurence" + _ -> unifyOne (t', t2') + +unifyOne (t1, TyVarTy v) | (notElem v (setToList (freeTyVar t1))) = + unifyOne (TyVarTy v, t1) + +unifyOne ((TyApp t1l t1r), (TyApp t2l t2r)) = + return $ Just ([EqCons t1l t2l, EqCons t1r t2r]) + +unifyOne ((FunTy t1l t1r), (FunTy t2l t2r)) = + return $ Just ([EqCons t1l t2l, EqCons t1r t2r]) + +unifyOne ((TyConstr t1), (TyConstr t2)) + | t1 == t2 = return $ Just [] + +unifyOne (t1, t2) = + do + t1' <- norm t1 + t2' <- norm t2 + case (t1, t1 /= t1') of + (TySyn _ _, True) -> return $ Just ([EqCons t1' t2]) + (TyApp _ _, _ ) -> phasefail "TyInfer:" $ "unifyOne: no unifier:" ++ (show t1) + (TyConstr _, _ ) -> phasefail "TyInfer:" $ "unifyOne: no unifier:" ++ (show t1) + _ -> + case (t2, t2 /= t2') of + (TyApp _ _, _ ) -> phasefail "TyInfer:" $ "unifyOne: no unifier:" ++ (show t2) + (TyConstr _, _ ) -> phasefail "TyInfer:" $ "unifyOne: no unifier:" ++ (show t2) + (TySyn _ _, True) -> return $ Just ([EqCons t2' t1]) + _ -> return Nothing + + + + +unifyC :: TC ([Constraint]) +unifyC = + do + uStr <- showU + sStr <- showSubs + u <- dTrace ("*unifyC*: \n" ++ uStr ++ sStr ++ "*\n") dumpU + let eqs = [(t1, t2) | eq@(EqCons t1 t2) <- u] + eqs' <- mapM unifyOne eqs + let res = map choose (zip eqs' u) + + if (all isNothing eqs') + then return u + else + do + u' <- mapM applyConstrSubst (concat res) + replaceU u' + u'' <- unifyC + return (u'') + where + choose (Nothing, u) = [u] + choose (Just c, _) = c + +-} addfile ./Unification.hs hunk ./Unification.hs 1 +module Unification ( + + unifyType + +) where + +import qualified Data.Set as Set +import AbstractSyntax +import Substitution +import Pretty +import Symtab +import Kinds + +unifyType :: Type -> Type -> ST (Either String TypeSubst) +unifyType (TyApp l r) (TyApp l' r') = + do s1 <- unifyType l l' + case s1 of + err@(Left _) -> return err + Right s1' -> + do s2 <- unifyType (applySubst s1' r) (applySubst s1' r') + case s2 of + err@(Left _) -> return err + Right s2' -> return $ Right (s2' `composeSubst` s1') +unifyType (TyVar id) t = varBind id t +unifyType t (TyVar id) = varBind id t +unifyType (TyConstruct id1) (TyConstruct id2) + | id1 == id2 = return (Right nullSubst) +unifyType t1 t2 = + return $ Left ("Types `" ++ showPpr t1 ++ "' and `" ++ showPpr t2 ++ + "' do not unify") + +varBind u t | t == TyVar u = return (Right nullSubst) + | u `Set.member` freeTypeVars t = + return $ Left ("variable `" ++ showPpr u ++ "' occurs in " ++ + showPpr t) + | otherwise = + do k1 <- kindOf u + k2 <- kindOf t + if k1 == k2 + then return $ Right (u +-> t) + else return $ Left ("kind mismatch while unifying `" ++ + showPpr u ++ "' with `" ++ showPpr t + ++ "'") addfile ./UniqIdents.hs hunk ./UniqIdents.hs 1 - +{-# OPTIONS_GHC -fglasgow-exts #-} +-- for deriving Data and Typeable + +module UniqIdents ( + + TypeVarId, TypeId, DataId, ClassId, AssocTypeId, MethodId, ValId, + + isPairTypeConstructor, isFunTypeConstructor, + isBoolTypeConstructor, isIntTypeConstructor, + isUnitTypeConstructor, builtinTypeId, + + NA, runNA, + + defineTypeVar, undefineTypeVar, isDefinedTypeVar, + + defineValVar, + + defineDataCon, defineTypeCon, + defineAssocTypeCon, defineClass, defineMethod, + + lookUpValVar, lookUpTypeVar, lookUpDataCon, lookUpTypeCon, + lookUpAssocTypeCon, lookUpClass, lookUpMethod, + + isAssocTypeCon, + + enterBlock, exitBlock, freshValVar + +) where + +import Error +import Pretty +import qualified Data.Generics as Gen +import qualified NameSpaces as NS +import qualified Map +import qualified ParseSyntax +import qualified Builtins + +-- +-- The data types for identifiers +-- + +type Version = Int + +data Id = Id !Version !String + deriving (Eq,Show,Read,Ord,Gen.Typeable,Gen.Data) + +type ParseId = ParseSyntax.Id + +mkId :: ParseId -> Int -> Id +mkId i v = Id v i + +newtype TypeVarId = TypeVarId Id + deriving (Eq,Show,Read,Ord,Gen.Typeable,Gen.Data) +newtype TypeId = TypeId Id + deriving (Eq,Show,Read,Ord,Gen.Typeable,Gen.Data) +newtype DataId = DataId Id + deriving (Eq,Show,Read,Ord,Gen.Typeable,Gen.Data) +newtype ClassId = ClassId Id + deriving (Eq,Show,Read,Ord,Gen.Typeable,Gen.Data) +newtype AssocTypeId = AssocTypeId Id + deriving (Eq,Show,Read,Ord,Gen.Typeable,Gen.Data) +newtype MethodId = MethodId Id + deriving (Eq,Show,Read,Ord,Gen.Typeable,Gen.Data) +newtype ValId = ValId Id + deriving (Eq,Show,Read,Ord,Gen.Typeable,Gen.Data) + +instance Pretty TypeVarId where + ppr (TypeVarId id) = ppr id + +instance Pretty TypeId where + ppr (TypeId id) = ppr id + +instance Pretty DataId where + ppr (DataId id) = ppr id + +instance Pretty ClassId where + ppr (ClassId id) = ppr id + +instance Pretty AssocTypeId where + ppr (AssocTypeId id) = ppr id + +instance Pretty MethodId where + ppr (MethodId id) = ppr id + +instance Pretty ValId where + ppr (ValId id) = ppr id + +instance Pretty Id where + ppr (Id v s) | v /= 0 = text s <> text "[" <> text (show v) + <> text "]" + ppr (Id _ s) = text s + + +isPairTypeConstructor (TypeId (Id v s)) = + v == 0 && s == Builtins.pairTypeConstructor +isFunTypeConstructor (TypeId (Id v s)) = + v == 0 && s == Builtins.funTypeConstructor +isIntTypeConstructor (TypeId (Id v s)) = + v == 0 && s == Builtins.intTypeConstructor +isBoolTypeConstructor (TypeId (Id v s)) = + v == 0 && s == Builtins.boolTypeConstructor +isUnitTypeConstructor (TypeId (Id v s)) = + v == 0 && s == Builtins.unitTypeConstructor + +builtinTypeId s = if s `elem` Builtins.typeConstructors + then TypeId (Id 0 s) + else panic ("Unknown builtin: " ++ s) + +-- The name analysis monad +-- ----------------------- + +-- Provides a mapping between names produced by the parser (plain strings) +-- and unique names (strings + version number). The usual scoping rules +-- apply. + +data NAState = + NAState { na_valueLevel :: NS.NameSpace ParseId (ValueLevelObjects), + na_typeVars :: Map.Map ParseId TypeVarId, + na_typeLevel :: Map.Map ParseId (TypeLevelObjects), + na_versions :: Map.Map ParseId Int } + +emptyNAState = NAState NS.nameSpace Map.empty Map.empty Map.empty + +data ValueLevelObjects = Value ValId + | Method MethodId + | DataCon DataId Int-- arity + +data TypeLevelObjects = TypeCon TypeId + | AssocTypeCon AssocTypeId + | Class ClassId + +newtype NA r = NA (NAState -> (r, NAState)) +unNA:: NA r -> NAState -> (r, NAState) +unNA (NA m) = m + +instance Monad NA where + return r = NA $ \s -> (r, s) + m >>= n = NA $ \s -> let (r, s') = unNA m s in unNA (n r) s' + fail s = panic ("fail in the NA monad: " ++ s) + +-- run a name analysis in a fresh NA environment +-- +runNA :: NA a -> a +runNA m = + let (r, s) = unNA m emptyNAState in r + +get :: (NAState -> a) -> NA a +get f = NA $ \s -> (f s, s) + +setValueLevel x = NA $ \s -> ((), s { na_valueLevel = x }) +setTypeVars x = NA $ \s -> ((), s { na_typeVars = x }) +setTypeLevel x = NA $ \s -> ((), s { na_typeLevel = x }) +setVersions x = NA $ \s -> ((), s { na_versions = x }) + +nextVersion :: ParseId -> NA Id +nextVersion id = + do m <- get na_versions + let v = Map.findWithDefault 0 id m + setVersions (Map.insert id (v+1) m) + return (mkId id v) + +define :: (NAState -> m) -- get the mapping + -> (m -> NA ()) -- save the mapping + -> (Id -> u) -- create the uid + -> (u -> w) -- wrap the uid + -> (ParseId -> w -> m -> (Maybe w, m)) -- store the uid + -> String -- what are we defining? + -> ParseId -- the id + -> NA u -- the resulting uid +define a save c w f s id = + do uid <- nextVersion id + let uid' = c uid + m <- get a + case f id (w uid') m of + (Just old, _) -> + phasefail (s ++ " `" ++ showPpr id ++ + "' already defined") + (_, m') -> do save m' + return uid' + +defineTypeVar :: ParseId -> NA TypeVarId +defineTypeVar = define na_typeVars setTypeVars TypeVarId (\x -> x) + Map.insertLookup "type variable" + +defineValue = define na_valueLevel setValueLevel + +defineValVar :: ParseId -> NA ValId +defineValVar = defineValue ValId Value NS.defLocal "value variable" + +defineDataCon :: ParseId -> Int -> NA DataId +defineDataCon id arity = defineValue DataId (flip DataCon arity) + NS.defGlobal "data constructor" id + +defineMethod :: ParseId -> NA MethodId +defineMethod = defineValue MethodId Method NS.defGlobal "method" + +defineType = define na_typeLevel setTypeLevel + +defineTypeCon :: ParseId -> NA TypeId +defineTypeCon = defineType TypeId TypeCon Map.insertLookup "type constructor" + +defineAssocTypeCon :: ParseId -> NA AssocTypeId +defineAssocTypeCon = defineType AssocTypeId AssocTypeCon + Map.insertLookup "associated type constructor" + +defineClass :: ParseId -> NA ClassId +defineClass = defineType ClassId Class Map.insertLookup "type class" + + +lookUp :: (NAState -> m) -- get the mapping + -> (ParseId -> m -> Maybe w) -- lookup the wrapped uid + -> (w -> Maybe u) -- unwrap the uid + -> String -- what is looked up? + -> ParseId -- the id + -> NA u -- the result +lookUp a l u s id = + do m <- get a + case l id m of + Just w -> + case u w of + Just uid -> return uid + Nothing -> phasefail ("`" ++ show (ppr id) ++ "' is not a " ++ s) + Nothing -> phasefail (s ++ " `" ++ show (ppr id) ++ "' does not exist") + +lookUpValue = lookUp na_valueLevel + +lookUpValVar :: ParseId -> NA ValId +lookUpValVar = lookUpValue NS.find (\w -> case w of + Value uid -> Just uid + _ -> Nothing) "value variable" +lookUpMethod :: ParseId -> NA MethodId +lookUpMethod = lookUpValue NS.findGlobal + (\w -> case w of + Method uid -> Just uid + _ -> Nothing) "method variable" + +lookUpDataCon :: ParseId -> NA (DataId, Int) +lookUpDataCon = lookUpValue NS.findGlobal + (\w -> case w of + DataCon uid i -> Just (uid, i) + _ -> Nothing) "data constructor" + +lookUpType = lookUp na_typeLevel Map.lookup + +lookUpTypeCon :: ParseId -> NA TypeId +lookUpTypeCon = lookUpType (\w -> case w of + TypeCon uid -> Just uid + _ -> Nothing) "type constructor" + +lookUpAssocTypeCon :: ParseId -> NA AssocTypeId +lookUpAssocTypeCon = lookUpType (\w -> case w of + AssocTypeCon uid -> Just uid + _ -> Nothing) + "associated type constructor" + +lookUpClass :: ParseId -> NA ClassId +lookUpClass = lookUpType (\w -> case w of + Class uid -> Just uid + _ -> Nothing) "type class" + +lookUpTypeVar :: ParseId -> NA TypeVarId +lookUpTypeVar = lookUp na_typeVars Map.lookup Just "type variable" + +isAssocTypeCon :: ParseId -> NA Bool +isAssocTypeCon id = + do m <- get na_typeLevel + case Map.lookup id m of + Just (AssocTypeCon _) -> return True + _ -> return False + +undefineTypeVar :: TypeVarId -> NA () +undefineTypeVar (TypeVarId (Id _ id)) = + do m <- get na_typeVars + let m' = case Map.lookup id m of + Nothing -> phasefail ("cannot undefine non-existing type \ + \variable `" ++ show (ppr id) ++ "'") + Just _ -> Map.delete id m + setTypeVars m' + +isDefinedTypeVar :: ParseId -> NA Bool +isDefinedTypeVar id = + do m <- get na_typeVars + case Map.lookup id m of + Nothing -> return False + _ -> return True + +enterBlock :: NA () +enterBlock = + do ns <- get na_valueLevel + setValueLevel (NS.enterNewRange ns) + +exitBlock :: NA () +exitBlock = + do ns <- get na_valueLevel + setValueLevel (fst $ NS.leaveRange ns) + +freshValVar :: ParseId -> NA ValId +freshValVar id = + do uid <- nextVersion id + return (ValId uid) addfile ./WellFormedProgram.hs hunk ./WellFormedProgram.hs 1 +-- +-- Copyright (C) 2005 Gabriele Keller (keller@cse.unsw.edu.au) +-- Stefan Wehr - http://www.stefanwehr.de +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License as +-- published by the Free Software Foundation; either version 2 of +-- the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +-- + +module WellFormedProgram where + +-- ICFP draft, section 5.1 + +import qualified Data.Set as Set +import qualified Data.Generics as Gen +import qualified Data.Typeable +import qualified List +import AbstractSyntax +import Error +import Pretty +import Symtab +import Unification + + +checkAfterKindInference :: Program -> ST () +checkAfterKindInference p@(Program tydefs classDecs classInsts binds) = + do mapM checkOverlappingInstances classDecs + return () + +-- Instances must not overlap. +-- {overlapping.mhs} +-- FIXME: need symbol table and unification +checkOverlappingInstances :: ClassDec -> ST () +checkOverlappingInstances cd = + do insts <- findInstances (class_name cd) + checkOverlaps insts + where checkOverlaps [] = return () + checkOverlaps (i:is) = + do l <- mapM (overlap i) is + if or l + then phasefail ("overlapping instances for class " ++ + showPpr (class_name cd)) + else checkOverlaps is + overlap i1 i2 = + do res <- unifyType (inst_type i1) (inst_type i2) + case res of + Left _ -> return False + Right _ -> return True + +check :: Program -> ST () +check p@(Program tydefs classDecs classInsts binds) = + do mapM checkClassDec classDecs + mapM checkInstanceDec classInsts + Gen.everywhereM (Gen.mkM checkBind) p + Gen.everywhereM (Gen.mkM checkAssocTypeApplication) p + return () + +-- class hierarchy must be acyclic +-- {cyclic_class_hierarchy.mhs} +-- => checked while building symtab +-- FIXME: need symbol table and cycle check + + +--------------------------------------------------- +-- well-formedness checks for class declarations -- +--------------------------------------------------- + +checkClassDec :: ClassDec -> ST () +checkClassDec d = + do checkClassContext d + checkMethodSigs d + return () + +-- An associated type synonym must be parameterised over all +-- parameters of the class, and these type variables must come first, +-- and be in the same order as in the class. +-- {illegal_assoc_decl1.mhs, illegal_assoc_decl2.mhs} + +-- => for single parameter type classes, this property is guaranteed by +-- the syntax transformation. + + +-- The context of the class may constraint only type variables mentioned +-- in the class head. +-- {constraining_unbound_var1.mhs} +checkClassContext :: ClassDec -> ST () +checkClassContext (ClassDec id param constrs _ _) = + mapM_ checkConstr constrs + where checkConstr (ClassConstraint _ (TyVar _)) = + return () -- syntax transformation guarantees that only + -- class variables are constrained + checkConstr (ClassConstraint _ _) = + phasefail ("illegal context for class " ++ showPpr id ++ + ": only type variables can be constrained") + +-- The signature of a method must not constrain the class parameter. +-- The class parameter must be contained in Fixv(simga) for all +-- method signatures sigma. +-- {constrain_class_param.mhs, ambiguous1.mhs} +checkMethodSigs (ClassDec id param _ _ msigs) = + do mapM checkClassParamUnconstrained msigs + mapM checkFixv msigs + mapM checkEqConstraints msigs + return () + where + checkClassParamUnconstrained (mid, TypeScheme _ (ConstrainedType c _)) = + if param `Set.member` freeTypeVars c + then phasefail ("signature of method " ++ showPpr mid ++ + " of class " ++ + showPpr id ++ " constrains the class parameter") + else return () + checkClassParamUnconstrained _ = return () + checkFixv (mid, ts) = + if not $ param `Set.member` fixedTypeVars ts + then phasefail ("signature of method " ++ showPpr mid ++ + " of class " ++ + showPpr id ++ " is invalid.") + else return () + checkEqConstraints (_, TypeScheme _ (ConstrainedType cs _)) = + do mapM checkConstraint cs + return () + checkEqConstraints (_, _) = return () + +------------------------------------------------------ +-- well-formedness checks for instance declarations -- +------------------------------------------------------ + +checkInstanceDec :: ClassInst -> ST () +checkInstanceDec ci@(ClassInst clazz ty constrs tyBind methodBinds) = + do mapM checkConstraint constrs + checkIfAllAssocTypesAreDefined ci + checkIfAllMethodsAreDefined ci + checkConstructorBased ci + checkInstanceConstraints ci + checkAssocTypeHead ci tyBind + checkAssocTypeDefinition tyBind + return () + +-- Instance heads must be constructor based, a single variable is not allowed. +-- All variables in the instance head must be distinct. +-- {illegal_instance_head.mhs, instance_for_tyvar.mhs} +checkConstructorBased :: ClassInst -> ST () +checkConstructorBased (ClassInst clazz (TyVar _) _ _ _) = + phasefail ("illegal instance declaration for class " ++ showPpr clazz ++ + ": single type variable not allowed in instance head") +checkConstructorBased (ClassInst clazz ty _ _ _) = + let vars = allTypeVars ty + in if length vars /= length (List.nub vars) + then phasefail ("duplicate type variable in head of instance " ++ + "for class " ++ showPpr clazz) + else return () + +-- All constraints in the instance context must be of the form C a (where +-- C is a class and a is a type variable) or T a1..aN = t (where T a1..aN +-- is the saturated application of an associated type synonym and t is +-- a type but not a single variable; all arguments to synonym applications +-- in t must be variables). +-- {illegal_instance_constraint1.mhs, illegal_instance_constraint2.mhs, +-- illegal_instance_constraint3.mhs} +checkInstanceConstraints (ClassInst clazz _ constrs _ _) = + do mapM checkConstraint constrs + return () + where + checkConstraint c@(CC (ClassConstraint _ ty)) = + case ty of + TyVar _ -> return () + _ -> phasefail ("illegal constraint in instance declaration for " ++ + "class " ++ showPpr clazz ++ ": " ++ showPpr c) + checkConstraint c@(EC (EqConstraint (AssocType _ ps) t)) = + let isTyVar (TyVar _) = True + isTyVar _ = False + allSynArgs = Gen.everything (++) ([] `Gen.mkQ` synArgs) t + synArgs (AssocType _ ps) = ps + cond1 = and (map isTyVar ps) + cond2 = not (isTyVar t) + cond3 = and (map isTyVar allSynArgs) + in if cond1 && cond2 && cond3 + then return () + else phasefail ("illegal constraint in instance declaration " + ++ "for class " ++ showPpr clazz ++ + ": " ++ showPpr c) + +-- All associated type synonyms of the corresponding class must be defined +-- (we don't have default definitions). +-- {missing_assoc_type.mhs} +checkIfAllAssocTypesAreDefined (ClassInst classId _ _ tyBind _) = + do clazz <- findClass classId + if length (class_tsigs clazz) /= 1 + then phasefail ("illegal instance declaration for class " ++ + showPpr classId ++ ": type synonyms do not match") + else return () + let classTId = fst $ (class_tsigs clazz)!!0 + if classTId /= assocBind_name tyBind + then phasefail ("illegal instance declaration for class " ++ + showPpr classId ++ ": type synonyms do not match") + else return () + +-- All methods of the corresponding class must be defined. +-- {missing_method.mhs} +checkIfAllMethodsAreDefined (ClassInst classId _ _ _ vbinds) = + do clazz <- findClass classId + let vsigs = class_vsigs clazz + if length vsigs /= length vbinds + then phasefail ("illegal instance declaration for class " ++ + showPpr classId ++ ": methods do not match") + else return () + mapM checkMethodDefinition (zip (List.sortBy cmpVsig vsigs) + (List.sortBy cmpVbind vbinds)) + return () + where + cmpVsig (id1,_) (id2,_) = id1 `compare` id2 + cmpVbind b1 b2 = method_name b1 `compare` method_name b2 + checkMethodDefinition ((id,_), mb) | id == method_name mb = return () + | otherwise = + phasefail ("illegal instance declaration for class " ++ + showPpr classId ++ ": methods do not match") + + +-- The head of the definition of an associated type synonym must repeat +-- the instance parameters and all other parameters must be simple +-- variables. The overall number of parameters must be the same as in the +-- class declaration. +-- {not_repeating_params.mhs, param_number_not_ok.mhs} +checkAssocTypeHead :: ClassInst -> AssocTypeBind -> ST () +checkAssocTypeHead ci at = + do let id = assocBind_name at + (_, params) <- findAssocTypeSig id + if length params /= 1 + (length $ assocBind_params at) + then phasefail ("wrong number of arguments in definition of " ++ + "associated type synonym " ++ showPpr id) + else return () + if assocBind_index at /= inst_type ci + then phasefail ("definiton of associated type synonym must " ++ + "repeat the type of the instance head") + else return () + +checkAssocTypeDefinition :: AssocTypeBind -> ST () +checkAssocTypeDefinition atb@(AssocTypeBind id p ps ty) = + do -- Definitions of ATSs must be constructor based (trivial because + -- instance heads must be constructor based) + ok + -- Definitions of ATSs must be left linear (trivial because + -- left-linearity of the index of the AT is ensured by the + -- left-linearity of the instance head and the syntax transformation + -- makes sure that all other type variables are distinct. + -- {not_left_linear.mhs} + ok + -- Definitions must be non-overlapping (trivial because instances must + -- be non-overlapping). + ok + -- Definitions must be decreasing and linear in arguments to synonym + -- applications. + -- {not_decreasing.mhs, not_linear_in_args.mhs} + checkDecreasingAssocTypeDefinition atb + where + ok = return () + +checkDecreasingAssocTypeDefinition (AssocTypeBind id p ps ty) = + do let m = dataConstructorCount p + n = if length (allAssocTypes ty) == 0 then 0 + else maximum (map assocTypeDataConstructorCount + (allAssocTypes ty)) + if n >= m + then phasefail ("Definition of associated type synonym " ++ + showPpr id ++ " is not decreasing. Number of " ++ + "data constructors in definition head: " ++ + show m ++ ". Number of data constructors on the " + ++ "right side: " ++ show n) + else return () + mapM (\args -> if length args /= length (List.nub args) + then + phasefail ("Definition of associated type synonym " ++ + showPpr id ++ " contains a non-linear " ++ + "type synonym application") + else return ()) + (map allTypeVars (allAssocTypes ty :: [AssocType])) + return () + where + assocTypeDataConstructorCount (AssocType _ ps) = + sum (map dataConstructorCount ps) + allAssocTypesArgs ty = map (\ (AssocType _ ps) -> ps) (allAssocTypes ty) + dataConstructorCount = Gen.everything (+) + (0 `Gen.mkQ` (\t -> case t of TyConstruct _ -> 1 + _ -> 0)) + +--------------------------------------------------------- +-- well-formedness checks for associated type synonyms -- +--------------------------------------------------------- + +-- all applications of associated type synonyms must be saturated +-- {not_saturated1.mhs, not_saturated2.mh, not_saturated3.mhs} +checkAssocTypeApplication :: AssocType -> ST AssocType +checkAssocTypeApplication at = + do sig <- findAssocTypeSig (assoc_name at) + if length (snd sig) /= length (assoc_params at) + then phasefail ("application `" ++ showPpr at ++ "' of associated " ++ + "type synonym is not saturated") + else return at + +-------------------------------------------------------------- +-- well-formedness checks for user-supplied type annotations - +-------------------------------------------------------------- + +-- for all signatures 'forall a1..aN . rho': +-- 'a1..aN `intersect` Free(rho)' must be a subset of Fixv(rho) + +-- => we check this after type inference, because we have to do it for +-- ALL signatures +{- +checkIfSignatureAmbiguous :: TypeScheme -> ST () +checkIfSignatureAmbiguous ts@(TypeScheme alphas rho) = + if not $ + (Set.fromList alphas `Set.intersection` freeTypeVars rho) + `Set.isSubsetOf` + fixedTypeVars rho + then phasefail ("signature `" ++ showPpr ts ++ "' is ambiguous") + else return () +-} + +-- in equality constraints, the 1st argument of the type synonym application +-- in the left side must be a type variable. +-- {eq_constraint1.mhs, eq_constraint2.mhs, eq_constraint3.mhs, +-- eq_constraint4.mhs} +checkConstraint :: Constraint -> ST () +checkConstraint (CC _) = return () +checkConstraint (EC (EqConstraint (AssocType _ (TyVar _ : _)) _)) = return () +checkConstraint (EC (EqConstraint (AssocType name _) _)) = + phasefail ("invalid associated type synonym `" ++ showPpr name ++ + "' in equality constraint (first parameter is not a variable)") + + +---------------------- +-- checks for binds -- +---------------------- + +checkBind :: ValBind -> ST ValBind +checkBind b@(ValBind _ (Just (TypeScheme _ (ConstrainedType cs _))) _ e) = + do mapM checkConstraint cs + return b + +checkBind b@(_) = return b + +-- +-- Helpers +-- + +allAssocTypes :: (Gen.Data a) => a -> [AssocType] +allAssocTypes x = + Gen.everything (++) ([] `Gen.mkQ` (\ a@(AssocType _ _) -> [a])) x + +allTypeVars :: (Gen.Data a) => a -> [TypeVarId] +allTypeVars x = Gen.everything (++) ([] `Gen.mkQ` allTypeVars) x + where allTypeVars (TyVar id) = [id] + allTypeVars _ = [] addfile ./WellFormedTypes.hs hunk ./WellFormedTypes.hs 1 +module WellFormedTypes where addfile ./configure.ac hunk ./configure.ac 1 +# +# Copyright (c) 2003 Don Stewart - http://www.cse.unsw.edu.au/~dons +# GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) +# + +# sanity test +AC_INIT(Main.hs) + +AC_PREREQ(2.57) + +# allow user supplied haskell compiler +AC_ARG_WITH(ghc, + AC_HELP_STRING([--with-ghc=],[use a specific Haskell compiler]), + [ GHC="$withval" ], + [ AC_CHECK_PROG(GHC,ghc,ghc) + if test -z "$GHC" ; then + AC_MSG_ERROR(You need GHC to build this project) + fi + ] +) + +# check ghc version here +if test -n "$GHC" ; then + AC_MSG_CHECKING([for ghc version]) + GHC_VERSION=`$GHC --numeric-version` + AC_MSG_RESULT([$GHC_VERSION]) +fi +AC_SUBST(GHC_VERSION) + +# Work out value of __GLASGOW_HASKELL__ +if test -n "$GHC" ; then + AC_MSG_CHECKING([for value of __GLASGOW_HASKELL__]) + echo "main = print __GLASGOW_HASKELL__" > t.hs + GLASGOW_HASKELL=`echo 'main' | "$GHC" --interactive -v0 -cpp t.hs` + rm t.hs + AC_MSG_RESULT([$GLASGOW_HASKELL]) +fi +AC_SUBST(GLASGOW_HASKELL) + +AC_CHECK_PROG(ALEX,alex,alex) +if test -z "$ALEX" ; then + AC_MSG_WARN(You need Alex if you modify the lexer) +fi + +AC_CHECK_PROG(HAPPY,happy,happy) +if test -z "$HAPPY" ; then + AC_MSG_WARN(You need Happy if you modify the lexer) +fi + +AC_PATH_PROG(PERL,perl,perl) +if test -z "$PERL" ; then + AC_MSG_WARN(You will need perl if you want to run the testsuite) +fi + +AC_PATH_PROG(DIFF,diff,diff) +if test -z "$DIFF" ; then + AC_MSG_WARN(You will need diff if you want to run the testsuite) +fi + +AC_CHECK_PROG(STRIP,strip,strip) + +AC_CONFIG_FILES(mk/config.mk) + +AC_OUTPUT + addfile ./ghci hunk ./ghci 1 +#!/bin/sh + +# helper script for running the ghci with the preprocessor + +PP=`dirname $0`/pp/logpp +exec ghci -pgmF "$PP" -F $@ addfile ./mk/config.mk.in hunk ./mk/config.mk.in 1 +# +# Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons +# GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) +# + +PREFIX= @prefix@ +BINDIR= @prefix@/bin +LIBDIR= @prefix@/lib/$(PKG) +DATADIR= @prefix@/share/doc/$(PKG) +IFACEDIR= $(LIBDIR)/imports + +# +# config.mk +# variables that need to be visible in Makefiles +# + +# full path to GHC +GHC = @GHC@ + +# any extra flags you want +HC_OPTS = +#-Wall -Werror +#HC_OPTS+= -Onot -fasm -H64m +#HC_OPTS += -fvia-C -funbox-strict-fields -O2 + +GHC_VERSION= @GHC_VERSION@ +GLASGOW_HASKELL= @GLASGOW_HASKELL@ + +# full path to alex, if you need to modify the lexer +ALEX = @ALEX@ + +# Optimise for GHC. Much smaller lexer +ALEX_OPTS = --ghc + +# full path to happy, needed if you modify the parser +HAPPY = @HAPPY@ + +# Optimise for GHC +HAPPY_OPTS = -acg + +STRIP = @STRIP@ + +INSTALL= sh $(TOPDIR)/install-sh -c +INSTALL_PROGRAM=$(INSTALL) -m 755 +INSTALL_DATA= $(INSTALL) -m 644 +INSTALL_DIR= mkdir -p +CP= cp +RM= rm -f addfile ./mk/paths.mk hunk ./mk/paths.mk 1 +################################################################################ +# +# paths.mk +# +# This file defines Make variables for standard directories +# and file lists +# +################################################################################ + +# +# +# Standard variable names +# +# +# The fptools mk setup defines a set of standard names which are used +# by the standard targets provided by mk. One example of this is the +# use of standard names for specifying what files to compile, their +# intermediate/object code, and the name of the final +# executable. Based on the settings of these variables, the standard +# targets will generate/expand rules that automatically compile and +# link your program. +# +# The general rules: +# +# SRCS - sources, might be prefixed to indicate what type of source +# they are. +# OBJS - object files (possibly prefixed). +# +# PROG - name of final executable +# +# We attempt to automatically devine the list of sources $(SRCS) to +# compile by looking in the directories which may be specified by +# setting the $(ALL_DIRS) variable. This is complicated by the fact +# that some files are derived from other files: eg. .hsc files give +# rise to -hsc.c and -hsc.h files, .ly files give rise to .hs files, +# and .hs files give rise to .hc files sometimes. + +# So we figure out the sources in three stages: first figure out what +# sources we can find (this is $(ALL_SRCS)). Then figure out all the +# "derived" sources (eg. A.hsc generates A.hs and A_hsc.c), and +# finally put all these together and remove duplicates (GNU make's +# handy sort function does the duplicate removing). + +# HS_SRCS: list of Haskell modules you want to compile. +# (also use by depend rule). +# HS_OBJS: list of corresponding object files +# HS_PROG: program that is ultimately linked. +# HS_IFACES: list of interface files generated +# (caveat: assuming no funny use of -hisuf and that +# file name and module name match) + +ALL_SRCS = $(wildcard $(patsubst ./%, %, \ + $(patsubst %,%/*.hs, $(ALL_DIRS)) \ + $(patsubst %,%/*.lhs, $(ALL_DIRS)) \ + $(patsubst %,%/*.y, $(ALL_DIRS)) \ + $(patsubst %,%/*.ly, $(ALL_DIRS)) \ + $(patsubst %,%/*.x, $(ALL_DIRS)) \ + $(patsubst %,%/*.c, $(ALL_DIRS)) \ + $(patsubst %,%/*.hc, $(ALL_DIRS)) \ + $(patsubst %,%/*.S, $(ALL_DIRS)) \ + $(patsubst %,%/*.prl, $(ALL_DIRS)) \ + $(patsubst %,%/*.lprl, $(ALL_DIRS)) \ + $(patsubst %,%/*.lit, $(ALL_DIRS)) \ + $(patsubst %,%/*.verb, $(ALL_DIRS)) \ + $(patsubst %,%/*.hsc, $(ALL_DIRS)) \ + $(patsubst %,%/*.gc, $(ALL_DIRS)) \ + )) $(EXTRA_SRCS) + +# ALL_SRCS is computed once and for all into PRE_SRCS at the top of +# rules.mk. Otherwise, we end up re-computing ALL_SRCS every time it +# is expanded (it is used in several variables below, and these +# variables are used in several others, etc.), which can really slow +# down make. + +PRE_HS_SRCS = $(filter %.hs, $(PRE_SRCS)) +PRE_LHS_SRCS = $(filter %.lhs, $(PRE_SRCS)) + +GC_SRCS = $(filter %.gc, $(PRE_SRCS)) +HSC_SRCS = $(filter %.hsc, $(PRE_SRCS)) +HAPPY_Y_SRCS = $(filter %.y, $(PRE_SRCS)) +HAPPY_LY_SRCS = $(filter %.ly, $(PRE_SRCS)) +HAPPY_SRCS = $(HAPPY_Y_SRCS) $(HAPPY_LY_SRCS) +ALEX_SRCS = $(filter %.x, $(PRE_SRCS)) + +DERIVED_GC_SRCS = $(patsubst %.gc, %.hs, $(GC_SRCS)) \ + $(patsubst %.gc, %_stub_ffi.c, $(GC_SRCS)) \ + $(patsubst %.gc, %_stub_ffi.h, $(GC_SRCS)) + +DERIVED_HSC_SRCS = $(patsubst %.hsc, %.hs, $(HSC_SRCS)) \ + $(patsubst %.hsc, %_hsc.c, $(HSC_SRCS)) \ + $(patsubst %.hsc, %_hsc.h, $(HSC_SRCS)) \ + $(patsubst %.hsc, %.hc, $(HSC_SRCS)) + +DERIVED_HAPPY_SRCS = $(patsubst %.y, %.hs, $(HAPPY_Y_SRCS)) \ + $(patsubst %.ly, %.hs, $(HAPPY_LY_SRCS)) + +DERIVED_ALEX_SRCS = $(patsubst %.x, %.hs, $(ALEX_SRCS)) + +DERIVED_HC_SRCS = $(patsubst %.hs, %.hc, $(PRE_HS_SRCS)) \ + $(patsubst %.lhs, %.hc, $(PRE_LHS_SRCS)) + +DERIVED_SRCS = $(DERIVED_GC_SRCS) \ + $(DERIVED_HSC_SRCS) \ + $(DERIVED_HAPPY_SRCS) \ + $(DERIVED_ALEX_SRCS) \ + $(DERIVED_HC_SRCS) + +# EXCLUDED_SRCS can be set in the Makefile, otherwise it defaults to empty. +EXCLUDED_GC_SRCS = $(filter %.gc, $(EXCLUDED_SRCS)) +EXCLUDED_HSC_SRCS = $(filter %.hsc, $(EXCLUDED_SRCS)) +EXCLUDED_HAPPY_Y_SRCS = $(filter %.y, $(EXCLUDED_SRCS)) +EXCLUDED_HAPPY_LY_SRCS = $(filter %.ly, $(EXCLUDED_SRCS)) +EXCLUDED_HAPPY_SRCS = $(EXCLUDED_HAPPY_Y_SRCS) $(EXCLUDED_HAPPY_LY_SRCS) +EXCLUDED_ALEX_SRCS = $(filter %.x, $(EXCLUDED_SRCS)) +EXCLUDED_HS_SRCS = $(filter %.hs, $(EXCLUDED_SRCS)) +EXCLUDED_LHS_SRCS = $(filter %.lhs, $(EXCLUDED_SRCS)) +EXCLUDED_DERIVED_SRCS = $(patsubst %.hsc, %.hs, $(EXCLUDED_HSC_SRCS)) \ + $(patsubst %.hsc, %_hsc.h, $(EXCLUDED_HSC_SRCS)) \ + $(patsubst %.hsc, %_hsc.c, $(EXCLUDED_HSC_SRCS)) \ + $(patsubst %.hsc, %.hc, $(EXCLUDED_HSC_SRCS)) \ + $(patsubst %.gc, %_stub_ffi.c, $(EXCLUDED_GC_SRCS)) \ + $(patsubst %.gc, %_stub_ffi.h, $(EXCLUDED_GC_SRCS)) \ + $(patsubst %.y, %.hs, $(EXCLUDED_HAPPY_Y_SRCS)) \ + $(patsubst %.ly, %.hs, $(EXCLUDED_HAPPY_LY_SRCS)) \ + $(patsubst %.x, %.hs, $(EXCLUDED_ALEX_SRCS)) \ + $(patsubst %.hs, %.hc, $(EXCLUDED_HS_SRCS)) \ + $(patsubst %.lhs, %.hc, $(EXCLUDED_LHS_SRCS)) \ + $(patsubst %.hs, %_stub.c, $(EXCLUDED_HS_SRCS)) \ + $(patsubst %.lhs, %_stub.c, $(EXCLUDED_LHS_SRCS)) + +# Exclude _hsc.c files; they get built as part of the cbits library, +# not part of the main library + +CLOSED_EXCLUDED_SRCS = $(sort $(EXCLUDED_SRCS) $(EXCLUDED_DERIVED_SRCS)) + +SRCS = $(filter-out $(CLOSED_EXCLUDED_SRCS), \ + $(sort $(PRE_SRCS) $(DERIVED_SRCS))) + +HS_SRCS = $(filter %.lhs %.hs, $(sort $(SRCS) $(BOOT_SRCS))) +HS_OBJS = $(addsuffix .$(way_)o,$(basename $(HS_SRCS))) +HS_IFACES = $(addsuffix .$(way_)hi,$(basename $(HS_SRCS))) + +GC_C_OBJS = $(addsuffix _stub_ffi.$(way_)o,$(basename $(filter %.gc,$(SRCS)))) +HSC_C_OBJS = $(addsuffix _hsc.$(way_)o,$(basename $(filter %.hsc,$(SRCS)))) + +# These are droppings from hsc2hs - ignore them if we see them. +EXCLUDED_C_SRCS += $(patsubst %.hsc, %_hsc_make.c, $(HSC_SRCS)) + +C_SRCS = $(filter-out $(EXCLUDED_C_SRCS),$(filter %.c,$(SRCS))) +C_OBJS = $(addsuffix .$(way_)o,$(basename $(C_SRCS))) + +# SCRIPT_SRCS: list of raw script files (in literate form) +# SCRIPT_OBJS: de-litted scripts +SCRIPT_SRCS = $(filter %.lprl,$(SRCS)) +SCRIPT_OBJS = $(addsuffix .prl,$(basename $(SCRIPT_SRCS))) + +OBJS = $(HS_OBJS) $(C_OBJS) $(GC_C_OBJS) + +# The default is for $(LIBOBJS) to be the same as $(OBJS) +LIBOBJS = $(OBJS) + +# +# Note that as long as you use the standard variables for setting +# which C & Haskell programs you want to work on, you don't have +# to set any of the clean variables - the default should do the Right +# Thing. +# + +#------------------------------------------------------------------ +# +# make depend defaults +# +# The default set of files for the dependency generators to work on +# is just their source equivalents. +# + +MKDEPENDHS_SRCS=$(HS_SRCS) +MKDEPENDC_SRCS=$(C_SRCS) + +#------------------------------------------------------------------ +# Clean file make-variables. +# +# The following three variables are used to control +# what gets removed when doing `make clean' +# +# MOSTLYCLEAN_FILES object code etc., but not stuff +# that is slow to recompile and/or stable +# +# CLEAN_FILES all files that are created by running make. +# +# MAINTAINER_CLEAN_FILES also clean out machine-generated files +# that may require extra tools to create. +# +# +# NOTE: $(SCRIPT_OBJS) is not in MOSTLY_CLEAN_FILES, because in some +# places in the tree it appears that we have source files in $(SCRIPT_OBJS). +# Specifically glafp-utils/mkdependC/mkdependC.prl and others in ghc/driver and +# possibly others elsewhere in the tree. ToDo: fix this properly. +MOSTLY_CLEAN_FILES += $(HS_OBJS) $(C_OBJS) $(HSC_C_OBJS) $(GC_C_OBJS) +CLEAN_FILES += $(HS_PROG) $(C_PROG) $(SCRIPT_PROG) $(SCRIPT_LINK) \ + $(PROG) $(LIBRARY) a.out \ + $(DERIVED_HSC_SRCS) \ + $(DERIVED_GC_SRCS) \ + $(patsubst %,%/*.$(way_)hi, . $(ALL_DIRS)) \ + $(patsubst %,%/*.p_hi, . $(ALL_DIRS)) \ + $(patsubst %,%/*.p_o, . $(ALL_DIRS)) + +# we delete *all* the .hi files we can find, rather than just +# $(HS_IFACES), because stale interfaces left around by modules which +# don't exist any more can screw up the build. + +# Don't clean the .hc files if we're bootstrapping +CLEAN_FILES += $(DERIVED_HC_SRCS) + +DIST_CLEAN_FILES += depend* *.hp *.prof configure mk/config.h mk/config.mk +DIST_CLEAN_DIRS= *.cache + +MAINTAINER_CLEAN_FILES += $(BOOT_SRCS) $(DERIVED_HAPPY_SRCS) $(DERIVED_ALEX_SRCS) + +# +# `Standard' set of files to clean out. +# +MOSTLY_CLEAN_FILES += \ + *.CKP *.ln *.BAK *.bak .*.bak *.o *.p_o core a.out errs ,* *.a .emacs_* \ + tags TAGS *.ind *.ilg *.idx *.idx-prev *.aux *.aux-prev *.dvi *.log \ + *.toc *.lot *.lof *.blg *.cb *_stub.c *_stub.h *.raw_s *.a.list \ + *.log *.status + addfile ./mk/rules.mk hunk ./mk/rules.mk 1 +# +# rules.mk : set flags and make rules +# + +# +# pull in the file search stuff +# +include $(TOPDIR)/mk/paths.mk + +PRE_SRCS:= $(ALL_SRCS) + +#HC_OPTS += $(INC_OPTS) +HSC_OPTS += -Imk $(INC_OPTS) +CC_OPTS += -Imk -optc-O3 $(INC_OPTS) + +# If $(way) is set then we define $(way_) and $(_way) from it in the +# obvious fashion. +ifeq "$(way)" "p" + way_ := $(way)_ + _way := _$(way) +endif + +# +# building the profiled way +# +ifeq "$(way)" "p" +PROF_OPTS = -prof -auto-all +LD_OPTS += $(PROF_OPTS) +HC_OPTS += $(PROF_OPTS) +HC_OPTS += -hisuf $(way_)hi -hcsuf $(way_)hc -osuf $(way_)o +endif + +# +# Binary flags +# +BIN_HC_OPTS += $(patsubst %,-package %, $(BIN_DEPS)) +BIN_LD_OPTS = $(BIN_LIBS) + +# +# Compute dependencies +# +depend: $(MKDEPENDHS_SRCS) + @echo -n "Rebuilding dependencies... " + @$(GHC) -M -optdep-f -optdepdepend $(HC_OPTS) $(MKDEPENDHS_SRCS) + @echo "done." + +# +# boot and all targets +# +.PHONY: boot all + +boot :: depend + +all :: $(HS_BINS) + +$(BIN) :: $(OBJS) $(BIN_OBJS) + $(GHC) -o $@ $(LD_OPTS) $(BIN_LD_OPTS) $(BIN_HC_OPTS) $(OBJS) $(BIN_OBJS) + $(STRIP) $(BIN) + +EXTRA_CLEANS+= $(BIN) + +# No need to define .SUFFIXES because we don't use any suffix rules +# Instead we use gmake's pattern rules exlusively + +.SUFFIXES: + +# This declaration tells GNU make to delete the target if it has +# changed and the command which created it exited with a non-zero exit +# code. + +.DELETE_ON_ERROR: + +# +# We anticipate wanting to use multiple ways. Particularly prof. +# + +%.$(way_)o: %.hs + $(GHC) $(HC_OPTS) -c $< -o $@ -ohi $(basename $@).$(way_)hi + +%.$(way_)o : %.lhs + $(GHC) $(HC_OPTS) -c $< -o $@ -ohi $(basename $@).$(way_)hi + +%.$(way_)hi : %.$(way_)o + @: + +%_hsc.c %_hsc.h %.hs : %.hsc + $(HSC2HS) $(HSC_OPTS) $(SYMS) $< + @touch $(patsubst %.hsc,%_hsc.c,$<) + +%.$(way_)o : %.c + @$(RM) $@ + $(GHC) $(CC_OPTS) -c $< -o $@ + +# preprocssed files, for haddock docs +# remember to strip #pragma lines from MacOSX cpp. +%.raw-hs : %.lhs + $(GHC) $(HC_OPTS) -D__HADDOCK__ -E -optP-P $< -o $@ + +%.raw-hs : %.hs + $(GHC) $(HC_OPTS) -D__HADDOCK__ -E -optP-P $< -o $@ + +# Alex Suffix Rules +%.hs : %.x + $(ALEX) $(ALEX_OPTS) $< + +# Happy Suffix Rules +%.hs : %.y + $(HAPPY) $(HAPPY_OPTS) $< + +# +# Building the haddock docs +# +ifneq "$(HADDOCK)" "" + +.PHONY: doc html +docs :: html +html :: html1 html2 + +HTML_DIR = html +HADDOCK_SRCS += $(HS_SRCS) +HS_PPS = $(addsuffix .raw-hs, \ + $(filter-out $(basename $(NO_DOCS)), \ + $(basename $(HADDOCK_SRCS)))) + +EXTRA_HS_PPS = $(addsuffix .raw-hs, $(basename $(NO_DOCS))) + +INSTALL_DATAS += $(HTML_DIR) + +# circular (excluded) modules first +html1 : $(EXTRA_HS_PPS) + @$(INSTALL_DIR) $(HTML_DIR) + $(HADDOCK) $(HADDOCK_OPTS)2 -o $(HTML_DIR) $(EXTRA_HS_PPS) -k $(PKG) + +html2 : $(HS_PPS) + @$(INSTALL_DIR) $(HTML_DIR) + $(HADDOCK) $(HADDOCK_OPTS) -o $(HTML_DIR) $(HS_PPS) -k $(PKG) + @cd $(HTML_DIR) && $(HADDOCK) --gen-index -i yi.interface -i yi.interface2 + +CLEAN_FILES += $(HS_PPS) $(EXTRA_HS_PPS) + +distclean :: + $(RM) -rf $(HTML_DIR) + +endif + +# +# cleaning +# +.PHONY: clean distclean + +clean: + $(RM) $(MOSTLY_CLEAN_FILES) $(EXTRA_CLEANS) $(CLEAN_FILES) + +distclean :: clean + $(RM) $(DIST_CLEAN_FILES) *~ */*~ + $(RM) -rf $(DIST_CLEAN_DIRS) + find tests -type f | sed -n '/^.*\/[0-9]*$$/p' | xargs rm + +# +# installing +# +# For each of these variables that is defined, you +# get one install rule +# +# INSTALL_PROGS executable programs in $(bindir) +# INSTALL_LIBS platform-dependent libraries in $(libdir) (ranlib'ed) +# INSTALL_DATAS platform-independent files in $(datadir) +# INSTALL_IFACES platform-dependent interface files in $(ifacedir) +# + +.PHONY: install install-dirs + +INSTALL_PROGS += $(HS_BINS) +INSTALL_IFACES += +INSTALL_LIBS += + +show-install : + @echo "BINDIR = $(BINDIR)" + @echo "LIBDIR = $(LIBDIR)" + @echo "DATADIR = $(DATADIR)" + +# the sed is to strip any trailing '_' from the inplace bin names. +ifneq "$(INSTALL_PROGS)" "" +install :: $(INSTALL_PROGS) + @$(INSTALL_DIR) $(BINDIR) + @for i in $(INSTALL_PROGS); do \ + j=`echo $$i | sed 's/_$$//'` ;\ + echo $(INSTALL_PROGRAM) $(INSTALL_BIN_OPTS) $$i $(BINDIR)/$$j ;\ + $(INSTALL_PROGRAM) $(INSTALL_BIN_OPTS) $$i $(BINDIR)/$$j ;\ + done +endif + +ifneq "$(INSTALL_LIBS)" "" +install :: $(INSTALL_LIBS) + @$(INSTALL_DIR) $(LIBDIR) + @for i in $(INSTALL_LIBS); do \ + echo $(INSTALL_DATA) $(INSTALL_OPTS) $$i $(LIBDIR) ;\ + $(INSTALL_DATA) $(INSTALL_OPTS) $$i $(LIBDIR) ;\ + done +endif + +ifneq "$(INSTALL_DATA)" "" +install :: $(INSTALL_DATAS) + @$(INSTALL_DIR) $(DATADIR) + @for i in $(INSTALL_DATAS); do \ + if [ -d $$i ] ; then \ + echo $(CP) -r $$i $(DATADIR)/ ;\ + $(CP) -r $$i $(DATADIR)/ ;\ + else \ + echo $(INSTALL_DATA) $(INSTALL_OPTS) $$i $(DATADIR)/ ;\ + $(INSTALL_DATA) $(INSTALL_OPTS) $$i $(DATADIR)/ ;\ + fi ;\ + done +endif + +ifneq "$(INSTALL_IFACES)" "" +install :: $(INSTALL_IFACES) + @$(INSTALL_DIR) $(IFACEDIR) + @for i in $(INSTALL_IFACES); do \ + $(INSTALL_DIR) $(IFACEDIR)/`dirname $$i` ;\ + echo $(INSTALL_DATA) $(INSTALL_OPTS) $$i $(IFACEDIR)/`dirname $$i`/ ; \ + $(INSTALL_DATA) $(INSTALL_OPTS) $$i $(IFACEDIR)/`dirname $$i`/ ; \ + done +endif + +install :: $(PKG).conf.install + @$(INSTALL_DIR) $(LIBDIR) + $(INSTALL_DATA) $(INSTALL_OPTS) $< $(LIBDIR)/$(PKG).conf + addfile ./pp/logpp hunk ./pp/logpp 1 - +#!/bin/sh + +origName=$1 +inName=$2 +outName=$3 +macros=`dirname $0`/macros.m4 + +if [ -z "origName" -o -z "$inName" -o -z "$outName" ] ; then + echo "Usage: $0 original-filename input-filename output-filename" + exit 1 +fi + +exec m4 -s "--define=__orig_file__=\"$origName\"" "$macros" "$inName" > "$outName" addfile ./pp/macros.m4 hunk ./pp/macros.m4 1 - +define(SRC_LOC_, (`__orig_file__', `__line__')) +define(panic, (panic_ `SRC_LOC_'))dnl +define(phasefail, (phasefail_ `SRC_LOC_'))dnl +define(pprPanic, (pprPanic_ `SRC_LOC_'))dnl +define(pprPhaseFail, (pprPhaseFail_ `SRC_LOC_'))dnl +changequote(,)dnl +changecom(",")dnl addfile ./tests/ast/should_fail/000.err hunk ./tests/ast/should_fail/000.err 1 +Parser error, next tokens: minhs: reading EOF! addfile ./tests/ast/should_fail/000.mhs hunk ./tests/ast/should_fail/000.mhs 1 +main = addfile ./tests/ast/should_fail/001.err hunk ./tests/ast/should_fail/001.err 1 +Parser error, next tokens: + line 2:9, IntegerT 1 + line 3:1, ReservedIdT "in" + line 3:4, VarIdT "x" addfile ./tests/ast/should_fail/001.mhs hunk ./tests/ast/should_fail/001.mhs 1 +main = let x :: Int + x = 1 +in x addfile ./tests/ast/should_fail/002.err hunk ./tests/ast/should_fail/002.err 1 +value variable `main' already defined addfile ./tests/ast/should_fail/002.mhs hunk ./tests/ast/should_fail/002.mhs 1 +main = 2; +main = 3; + addfile ./tests/ast/should_fail/003.err hunk ./tests/ast/should_fail/003.err 1 +type constructor `T' already defined addfile ./tests/ast/should_fail/003.mhs hunk ./tests/ast/should_fail/003.mhs 1 +data T = D1 Int; +data T = D2 Int; + addfile ./tests/ast/should_fail/004.err hunk ./tests/ast/should_fail/004.err 1 +data constructor `D' already defined addfile ./tests/ast/should_fail/004.mhs hunk ./tests/ast/should_fail/004.mhs 1 +data T1 = D Int; +data T2 = D Int; + addfile ./tests/ast/should_fail/005.err hunk ./tests/ast/should_fail/005.err 1 +type class `C' already defined addfile ./tests/ast/should_fail/005.mhs hunk ./tests/ast/should_fail/005.mhs 1 - +class C a where { +} + +class C a where { +} addfile ./tests/ast/should_fail/006.err hunk ./tests/ast/should_fail/006.err 1 +value variable `x' already defined addfile ./tests/ast/should_fail/006.mhs hunk ./tests/ast/should_fail/006.mhs 1 +main = let x = 4; + x = 3; + in 42; addfile ./tests/ast/should_fail/007.err hunk ./tests/ast/should_fail/007.err 1 +value variable `x' already defined addfile ./tests/ast/should_fail/007.mhs hunk ./tests/ast/should_fail/007.mhs 1 +main = letrec x = 4; + x = 3; + in 42; addfile ./tests/ast/should_fail/008.err hunk ./tests/ast/should_fail/008.err 1 +value variable `x' already defined addfile ./tests/ast/should_fail/008.mhs hunk ./tests/ast/should_fail/008.mhs 1 - +data T = D Int Bool; + +main = case 42 of D x x -> 0; +; addfile ./tests/ast/should_fail/009.err hunk ./tests/ast/should_fail/009.err 1 +data constructor `D' does not exist addfile ./tests/ast/should_fail/009.mhs hunk ./tests/ast/should_fail/009.mhs 1 - +main = case 42 of D -> 1;; addfile ./tests/ast/should_fail/Flag hunk ./tests/ast/should_fail/Flag 1 +expect-fail --no-location addfile ./tests/ast/should_pass/000.mhs hunk ./tests/ast/should_pass/000.mhs 1 +main :: Int; +main + = + let f :: (Int -> Int); + f x = x ; + + g :: Int; + g = 2 ; + in + f g ; addfile ./tests/ast/should_pass/000.out hunk ./tests/ast/should_pass/000.out 1 +data Int = +data Bool = + False + | True +data -> 1 2 = +data Unit = + () +data (,) 3 4 = + Pair 3 4 +main :: Int +main = let f :: Int -> Int + f x = x + ; + g :: Int + g = 2 + in f g addfile ./tests/ast/should_pass/001.mhs hunk ./tests/ast/should_pass/001.mhs 1 +f :: Int; +f = 1 ; + +g :: Bool; +g = True ; + +main :: Int; +main = f + f; addfile ./tests/ast/should_pass/001.out hunk ./tests/ast/should_pass/001.out 1 +data Int = +data Bool = + False + | True +data -> 1 2 = +data Unit = + () +data (,) 3 4 = + Pair 3 4 +f :: Int +f = 1 +g :: Bool +g = True +main :: Int +main = f + f addfile ./tests/ast/should_pass/002.mhs hunk ./tests/ast/should_pass/002.mhs 1 +plus :: Int -> Int -> Int; +plus x = let plus' :: Int -> Int; + plus' y = x + y; + in plus' +; +main :: Int; +main = 1 `plus` 2 `plus` 3; addfile ./tests/ast/should_pass/002.out hunk ./tests/ast/should_pass/002.out 1 +data Int = +data Bool = + False + | True +data -> 1 2 = +data Unit = + () +data (,) 3 4 = + Pair 3 4 +plus :: Int -> Int -> Int +plus x = let plus' :: Int -> Int + plus' y = x + y + in plus' +main :: Int +main = plus (plus 1 2) 3 addfile ./tests/ast/should_pass/003.mhs hunk ./tests/ast/should_pass/003.mhs 1 +class C a where { +} + +foo :: C a => (a -> a); +foo x = x +; +plus :: Int -> Int -> Int; +plus x = let plus' :: Int -> Int; + plus' y = x + y; + in plus' +; +main :: Int; +main = 1 `plus` 2 `plus` 3; addfile ./tests/ast/should_pass/003.out hunk ./tests/ast/should_pass/003.out 1 +data Int = +data Bool = + False + | True +data -> 1 2 = +data Unit = + () +data (,) 3 4 = + Pair 3 4 +class () => C a where +foo :: forall a[1] . C a[1] => a[1] -> a[1] +foo x = x +plus :: Int -> Int -> Int +plus x[1] = let plus' :: Int -> Int + plus' y = x[1] + y + in plus' +main :: Int +main = plus (plus 1 2) 3 addfile ./tests/ast/should_pass/004.mhs hunk ./tests/ast/should_pass/004.mhs 1 +class Nat n where { + type Sum n m; +} + +foo:: Sum a Bool = Int => (a -> a); +foo x = x +; + +plus :: Int -> Int -> Int; +plus x = let plus' :: Int -> Int; + plus' y = x + y; + in plus' +; + +main :: Int; +main = 1 `plus` 2 `plus` 3; addfile ./tests/ast/should_pass/004.out hunk ./tests/ast/should_pass/004.out 1 +data Int = +data Bool = + False + | True +data -> 1 2 = +data Unit = + () +data (,) 3 4 = + Pair 3 4 +class () => Nat n where + Sum n m +foo :: forall a . Sum a Bool = Int => a -> a +foo x = x +plus :: Int -> Int -> Int +plus x[1] = let plus' :: Int -> Int + plus' y = x[1] + y + in plus' +main :: Int +main = plus (plus 1 2) 3 addfile ./tests/ast/should_pass/005.mhs hunk ./tests/ast/should_pass/005.mhs 1 +foo x = x; +bar x = x + 1; addfile ./tests/ast/should_pass/005.out hunk ./tests/ast/should_pass/005.out 1 +data Int = +data Bool = + False + | True +data -> 1 2 = +data Unit = + () +data (,) 3 4 = + Pair 3 4 +foo x = x +bar x[1] = x[1] + 1 addfile ./tests/ast/should_pass/006.mhs hunk ./tests/ast/should_pass/006.mhs 1 +instance C Int where { + type T Int = Int -> Bool; + foo x = x; +} + +instance C D where { + type T D = Bool; + foo x = 42; +} + +class C a where { + type T a; + foo :: a -> Int; +} + +data D = D Int; + +bar x = foobar 2; + +foobar x = x * 2; + +main = let foo = 4; + in letrec bar = foo + 1; + in foobar bar; + + + addfile ./tests/ast/should_pass/006.out hunk ./tests/ast/should_pass/006.out 1 +data Int = +data Bool = + False + | True +data -> 1 2 = +data Unit = + () +data (,) 3 4 = + Pair 3 4 +data D = + D[1] Int +class () => C a where + T a + foo :: a -> Int +instance () => C Int where + T Int = Int -> Bool + foo x = x +instance () => C D where + T D = Bool + foo x[1] = 42 +bar x[2] = foobar 2 +foobar x[3] = x[3] * 2 +main = let foo[1] = 4 + in let bar[1] = foo[1] + 1 + in foobar bar[1] addfile ./tests/ast/should_pass/007.mhs hunk ./tests/ast/should_pass/007.mhs 1 - +data T1 = D1 Int T2; +data T2 = D2 Bool Int; + +main = D1 42 (D2 True 0); addfile ./tests/ast/should_pass/007.out hunk ./tests/ast/should_pass/007.out 1 +data Int = +data Bool = + False + | True +data -> 1 2 = +data Unit = + () +data (,) 3 4 = + Pair 3 4 +data T1 = + D1 Int T2 +data T2 = + D2 Bool Int +main = (\v v[1] -> D1 v v[1]) 42 ((\v[2] v[3] -> D2 v[2] v[3]) True 0) addfile ./tests/ast/should_pass/Flag hunk ./tests/ast/should_pass/Flag 1 +--dump-ast addfile ./tests/driver/check hunk ./tests/driver/check 1 +#!/usr/bin/perl +# +# Copyright (C) 2002-04 Don Stewart - http://www.cse.unsw.edu.au/~dons +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License as +# published by the Free Software Foundation; either version 2 of +# the License, or (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +# 02111-1307, USA. +# + +# check script for the various phases of the compiler + +sub find_leaves(); +sub is_leaf($); +sub get_toplevel_phases(); +sub find_tests(); +sub find_any_extra_flags(); + +# "check" runs the tests in all the subdirs. Tests look like *'.mhs' +# with a corresponding *'.out' file. + +$project = "minhs"; + +chdir "../.."; # assuming we are in "driver" +$TOP = `pwd`; +chomp $TOP; + +# +# some globals +# +#$diff = "$TOP/seci --cmp-abssyn"; # diff program +$diff = "diff -u"; + +$prog = "$TOP/$project"; # name of binary +$regress= "$TOP/tests"; # path to regression dir +$actual = "/tmp/$project.test.$$"; # actual output file + +$dfs = "find . -type d"; # how to do a dfs + +# for each top-level directory, keep a score of how many test were +# run, and how many failed. This has the form "name" => [0,0], +# initially +%score = (); + +# check the $prog exists +print "need to build $project first" and (exit 1) if (not -x "$prog"); + +# which compiler modules to check +# if the user has set a var, we use this instead +if ($#ARGV >= 0) { + @phases = @ARGV; +} else { + @phases = get_toplevel_phases(); +} + +$mark = 0; + +# for each compiler phase, run the regression tests in the leaf +# directories of that phase's tree +for $phase (@phases) { + + chdir "$regress/$phase/" or die "$0: couldn't chdir into $regress/$phase/: $!\n"; + + @leaves = find_leaves(); + + # for each leaf, run the tests found. + # is_leaf ensures that Tests.all exists in the directory + for $leaf (@leaves) { + + chdir "$regress/$phase/$leaf" or die "$0: couldn't chdir into $leaf: $!\n"; + + # canonicalise + $leaf = "" if ($leaf eq "."); + + # print where we are at + $base = $leaf; + $base =~ s%\./|$regress/$phase/%%g; # basename of dir we are in + if ($base eq "") { + print "======> $phase\n"; + } else { + print "======> $phase/$base\n"; + } + + # read expected mark distribution for this set of tests + $marks = find_marks(); + + # read in any flags needed to test this phase + $extra_flags = find_any_extra_flags(); + chomp $extra_flags; + + $expectfail = 0; # reset + if ($extra_flags =~ /expect-fail/) { + $expectfail = 1; + $extra_flags =~ s/expect-fail//g; + } + + # reset for each leaf directory. + # each leaf needs to contain a Marks file too. + $tested = $passed = 0; + + @tests = sort (find_tests()); + + for $test_ (@tests) { + + $result = ""; + + # find the basename of the test, sans suffix + ($test) = split /\./, $test_, 2; + + # actual input file, scanned from Tests.all + # couldn't find the extra '/' appended to $leaf... :{ + $source = "$test_"; # relative. + + # canonical name of expected results. + # add .err|.out if needed + $expect = "$regress/$phase/$leaf/$test"; + + # need to handle "should_fail". + + # override for now + #$extra_flags = "--dump-abssyn"; + + # run the compiler over this test file + if ($phase ne "codegen") { + `$prog $extra_flags $source > "$actual.out" 2> "$actual.err"`; + + if (not $expectfail) { + if ( $? != 0 or ($? >> 8) != 0 ) { + $result = `cat $actual.err 2> /dev/null`; + $result.= `cat $actual.out 2> /dev/null`; + } + + } elsif (not -s "$actual.err") { + $result = "unexpected pass!" ; + } else { + $result = `$diff "$expect.err" "$actual.err"`; + if ( $? >> 8 >= 2 ) { + $result = "diff failed!"; + } + } + + + # else it is codegeneration, which we handle differently + } else { + `$prog $extra_flags $source 2> "$actual.err"`; # compile + + if ( $? >> 8 ) { # if it didn't compile, hmm.. + $result .= `cat $actual.err` if ( $? ) ; + } else { + `$expect > "$actual.out" 2> "$actual.err"`; # run + } + } + + # if we don't already have failures + if (not $result and not $expectfail) { + + # diff the output (the actual files always exist, but + # we only care if they are non-null, or if there also + # exist expected files. that is, null output, and no + # expected files is ok. + $result = `$diff "$expect.out" "$actual.out"`; + if ( $? >> 8 >= 2 ) { + $result = "diff failed!"; + } + + # need some logic to cat the $actual.out if it exists, but + # the expected doesn't, instead of having diff die. + # if (-f "$expect.err") { # we expect something + # $result .= `$diff "$expect.err" "$actual.err"`; + + # if (-f "$actual.err") { # we didn't expect errors! + # $result .= `cat "$actual.err" | head -10`; + # } + + } + + if ($result) { + printf "=== %-15s failed ===\n", $test; + print "$result\n"; + } else { + printf "=== %-15s passed === \n", $test; + } + + # update the overall score + $score{$phase}[0]++ ; $total[0]++; + if (not $result) { + $score{$phase}[1]++ ; $total[1]++ + } + + # and update the leaf score: + $tested++; + $passed++ if (not $result); # i.e. success + + unlink "$actual.err"; + unlink "$actual.out"; + } # end for() + + # scale the test results to the proportion of marks assigned + # to this test: + if ($marks != "" and $marks != 0) { + printf ("\t\t\t\t\t%2.1f/%-2d marks\n", ($passed/$tested*$marks), $marks); + } + + # accumulate marks at each point: + $possiblemarks += $marks; + if ($tested != "" and $tested != 0) { + $achievedmarks += ($passed/$tested) * $marks; + } + + # reset just in case. + $marks = -1.0; + + } +} + +# and print out the numbers +print "\n"; +print "-" x 60; +print "\n--\n--\n"; + +for $p (@phases) { + printf "-- %15s : passed ", $p; + print (($score{$p}[1]+0) . "/" . ($score{$p}[0]+0) . " tests\n"); +} + +printf "--\n-- %15s : passed ", "total"; +print (($total[1]+0) . "/" . ($total[0]+0) . " tests"); +printf " (%0.1f%%)\n", (($total[1]+0) / ($total[0]+0) * 100); + +printf "--\n-- %15s : %.1f/%-d\n", "MARKS GAINED", $achievedmarks, $possiblemarks; + +print "--\n--\n"; +print "-" x 60; +print "\n"; + +exit 0; + +#----------------------------------------------------------------------- +#- Utilities + +# is_leaf: a directory is a leaf node if it contains any *.mhs files +sub is_leaf($) { + my $dir = shift; + opendir IN, $dir or die "couldn't open $dir in sub is_leaf()!\n"; + $found = grep { /\.mhs$/ } readdir(IN); + return ($found) ? 1 : 0; +} + +# return a list of leaf directories +sub find_leaves() { + open DIRS, "$dfs |" or die "$0: couldn't run '$dfs'!"; + my @dirs = ; + chomp @dirs; + return sort (grep { is_leaf($_) } @dirs); +} + +# find the top-level regress directories, filtering out the "driver" +sub get_toplevel_phases() { + chdir "$regress" or die "$0: couldn't chdir: $!"; + opendir DIR, "." or die "$0: couldn't opendir ./: $!"; + my @phases = grep { !/^\./ and !/driver/ } readdir(DIR); + closedir DIR; + chdir "driver"; # go home + return @phases; +} + +# return a sorted list of all *.mhs files in the current directory +sub find_tests() { + opendir DIR, "." or die "$0: couldn'd chdir: $!"; + my @tests = grep { /\.mhs$/ } readdir(DIR); + closedir DIR; + + # now remove all elems of @tests found in "Skip" file + open IN, "Skip" or return @tests; + @tests_ = @tests; + while () { + chomp; + $skip = $_; + @tests_ = grep { !/$skip/ } @tests_; + } + close IN; + return @tests_; +} + +# open the Flag file, if it exists, and read its contents +# the contents is a string of command line flags to append to the prog +sub find_any_extra_flags() { + open IN, "Flag" or return ""; + my $flag = ; + close IN; + return $flag; +} + +# open the Marks file, if it exists, and read its contents +# the contents is a numeric string telling us how many marks to scale +# these tests to. +sub find_marks() { + open IN, "./Marks" or return ""; + my $m = ; + close IN; + chomp $m; + return "" if ($m == "0"); + return $m; +} + +# vim: expandtab sw=4 ts=4 addfile ./tests/kind-inference/should_fail/000.mhs hunk ./tests/kind-inference/should_fail/000.mhs 1 - +data D a = D a (a Int); addfile ./tests/kind-inference/should_fail/001.mhs hunk ./tests/kind-inference/should_fail/001.mhs 1 - +data D a = D (a Int); + +foo :: D a -> a; +foo = 42; addfile ./tests/kind-inference/should_fail/002.mhs hunk ./tests/kind-inference/should_fail/002.mhs 1 +data D a = D a; + +class C a where { + type T a; +} + +instance C D where { + type T D = Int; +} addfile ./tests/kind-inference/should_fail/Flag hunk ./tests/kind-inference/should_fail/Flag 1 +expect-fail --no-location --dump-kindinfer addfile ./tests/kind-inference/should_pass/000.mhs hunk ./tests/kind-inference/should_pass/000.mhs 1 - +data T a b = D (a b); addfile ./tests/kind-inference/should_pass/001.mhs hunk ./tests/kind-inference/should_pass/001.mhs 1 - +data S a = S1 (a Int) + | S2 Unit + | S3 (D a); + +data D b = D1 (S b); + +class C c where { + bar :: c Int -> (D c, Bool); +} addfile ./tests/kind-inference/should_pass/002.mhs hunk ./tests/kind-inference/should_pass/002.mhs 1 +data D a b = D (a b) b; + +class C1 c where { + type T c; + foo :: c Int -> d -> Bool -> D c Int; +} + +class C1 e => C2 e where { +} + +instance C1 (D Int) where { + type T (D Int) = Bool; + foo = 42; +} addfile ./tests/kind-inference/should_pass/Flag hunk ./tests/kind-inference/should_pass/Flag 1 +--no-location --dump-kindinfer addfile ./tests/kind-inference/should_pass/depGroups.mhs hunk ./tests/kind-inference/should_pass/depGroups.mhs 1 +data D1 = D1; + +data D2 = D2 D1; + +data D3 = D3 D4; +data D4 = D4 D3 D1; + +class C1 a where { + foo :: a -> D3; +} + +class C1 a => C2 a where { +} + addfile ./tests/tyinfer/should_fail/ambiguous2.mhs hunk ./tests/tyinfer/should_fail/ambiguous2.mhs 1 +class C a where { + type T a; +} + +foo :: C a => T a -> T a; +foo x = x; + addfile ./tests/tyinfer/should_fail/ambiguous3.mhs hunk ./tests/tyinfer/should_fail/ambiguous3.mhs 1 +class C a where { + type T a; +} + +class D b where { + foo :: C a => b -> T a -> T a; +} addfile ./tests/tyinfer/should_pass/000.mhs hunk ./tests/tyinfer/should_pass/000.mhs 1 + +equal x y = True; + +bar x = equal x x; + + addfile ./tests/tyinfer/should_pass/001.mhs hunk ./tests/tyinfer/should_pass/001.mhs 1 +data List a = Cons a (List a) | Nil; + + +class Num a where { + sumNumList:: List a -> a; +} + +class Eq a where { + equal :: a -> a -> Bool; + dummy :: a -> a -> a; +} +class Collects c where { + type Elem c; + empty :: c; + insert:: Elem c -> c -> c; + toList:: c -> List c; +} + +instance Eq e => Collects (e -> Bool) where { + type Elem (e -> Bool) = e; + empty = let f x = False ; + in f; + insert e es = Cons e es;} + +instance Eq Int where { + type Elem (e -> Bool) = e; + equal x y = True; + dummy x y = x; +} + +mkList x = Cons x Nil; + +f1 = mkList; + +f2 xs = sumNumList (sumNumList xs); + +tst = equal 1 1; + + + +sumColl ys = sumNumList (toList ys); + +bar x = equal x x; + +-- insertTwo :: (Collects c => (Elem c -> Elem c -> c -> c)); +insertTwo k l coll = insert l (insert k coll); + + +-- foo:: a -> a; +foo x = + let y = 3; + in x; + + +main = 1 + 2 + (foo 3); addfile ./tests/tyinfer/should_pass/002.mhs hunk ./tests/tyinfer/should_pass/002.mhs 1 +class Collects c where { + type Elem c; + empty :: c; + insert:: Elem c -> c -> c; + -- toList:: c -> List c; +} +class Eq a where { + equal :: a -> a -> Bool; + dummy :: a -> a -> a; +} + +instance Eq e => Collects (e -> Bool) where { + type Elem (e -> Bool) = e; + empty = let f x = False ; + in f; + insert e es = Cons e es;} + +instance Eq Int where { + type Elem (e -> Bool) = e; + equal x y = True; + dummy x y = x; +} + +-- insertTwo :: (Collects c => (Elem c -> Elem c -> c -> c)); +insertTwo k l coll = insert l (insert k coll); + + addfile ./tests/tyinfer/should_pass/003.mhs hunk ./tests/tyinfer/should_pass/003.mhs 1 +class Num a where { + sumNumList:: List a -> a; +} + +class Collects c where { + type Elem c; + empty :: c; + insert:: Elem c -> c -> c; + toList:: c -> List (Elem c); +} + + + + +sumColl ys = sumNumList (toList ys); + +merge c1 c2 = foldr insert c2 (toList c1) addfile ./tests/tyinfer/should_pass/004.mhs hunk ./tests/tyinfer/should_pass/004.mhs 1 +class Nat n where { + type Add n m; + f:: Int -> Int; +} + +instance Nat Zero where { + type Add Zero m = m; + f x = 1; +} + +instance Nat n => Nat (Succ n) where { + type Add (Succ n) m = Succ (Add n m); + f x = 1; +} + + + + + + +h x y = y; +main = 1; + + addfile ./tests/tyinfer/should_pass/005.mhs hunk ./tests/tyinfer/should_pass/005.mhs 1 +class Nat n where { + type Add n m; + f:: Int -> Int; +} +class Nat n => VecBound n where { + type Vec n a; + appVec :: (VecBound m => (VecBound (Add n m) => (Vec n a -> Vec m a -> Vec (Add n m) a))); +} + + + +instance VecBound Zero where { + type Vec Zero a = VecZero; + appVec xs ys = ys; +} + + +instance VecBound n => VecBound (Succ n) where { + type Vec (Succ n) a = VecSucc; + appVec x xs ys = Cons x (appVec xs ys); +-- appVec (Cons x xs) ys = Cons x (appVec xs ys); +} + + +-- data VecZero = Nil +-- data VecBound n => VecSucc a = Cons a (Vec n a) + +main x = 1; addfile ./tests/tyinfer/should_pass/006.mhs hunk ./tests/tyinfer/should_pass/006.mhs 1 +class Nat n where { + type Add n m; +} + +class NNat n where { + type AAdd n m; +} + +h x y = y; +main = 1; + + addfile ./tests/tyinfer/should_pass/007.mhs hunk ./tests/tyinfer/should_pass/007.mhs 1 +class Eq a where { + equal :: a -> a -> Bool; + dummy :: a -> a -> a; +} + + +main x = equal x x; addfile ./tests/tyinfer/should_pass/008.mhs hunk ./tests/tyinfer/should_pass/008.mhs 1 +data Simp = A | B; +data List a = Cons a (List a) | Nil; + +foo x = Cons (Cons A Nil) Nil; + +main x = A; addfile ./tests/tyinfer/should_pass/009.mhs hunk ./tests/tyinfer/should_pass/009.mhs 1 +foo x = + letrec + g = (x,x); + in 1; + +main x = 1; addfile ./tests/tyinfer/should_pass/collects.mhs hunk ./tests/tyinfer/should_pass/collects.mhs 1 +class Eq a where { + equal :: a -> a -> Bool; + dummy :: a -> a -> a; +} + +class Collects c where { + type Elem c; + empty :: c; + insert:: Elem c -> c -> c; + -- toList:: c -> List c; +} + + +instance Eq e => Collects (e -> Bool) where { + type Elem (e -> Bool) = e; + empty = let f x = False ; + in f; + insert e es = Cons e es;} + +instance Eq Int where { + type Elem (e -> Bool) = e; + equal x y = True; + dummy x y = x; +} + + +insertTwo x y coll = insert y (insert x coll); + + +foo x = + let y = 3; + in x; + +main = 1 + 2 + (foo 3); addfile ./tests/well-formed/should_fail/.err hunk ./tests/well-formed/should_fail/.err 1 +./record_err.sh: line 8: minhs: command not found addfile ./tests/well-formed/should_fail/Flag hunk ./tests/well-formed/should_fail/Flag 1 +expect-fail --no-location addfile ./tests/well-formed/should_fail/ambiguous1.err hunk ./tests/well-formed/should_fail/ambiguous1.err 1 +signature of method foo of class C is invalid. addfile ./tests/well-formed/should_fail/ambiguous1.mhs hunk ./tests/well-formed/should_fail/ambiguous1.mhs 1 +class C a where { + type T a; + foo :: T a; +} addfile ./tests/well-formed/should_fail/constrain_class_param.err hunk ./tests/well-formed/should_fail/constrain_class_param.err 1 +signature of method foo of class C2 constrains the class parameter addfile ./tests/well-formed/should_fail/constrain_class_param.mhs hunk ./tests/well-formed/should_fail/constrain_class_param.mhs 1 +class C1 a where { } + +class C2 a where { + -- does not parse atm + foo :: C1 a => a; +} addfile ./tests/well-formed/should_fail/constraining_unbound_var1.err hunk ./tests/well-formed/should_fail/constraining_unbound_var1.err 1 +type variable `b' does not exist addfile ./tests/well-formed/should_fail/constraining_unbound_var1.mhs hunk ./tests/well-formed/should_fail/constraining_unbound_var1.mhs 1 +class C a where {} +class C b => D a where {} addfile ./tests/well-formed/should_fail/constraining_unbound_var2.err hunk ./tests/well-formed/should_fail/constraining_unbound_var2.err 1 +type variable `b' does not exist addfile ./tests/well-formed/should_fail/constraining_unbound_var2.mhs hunk ./tests/well-formed/should_fail/constraining_unbound_var2.mhs 1 +class C a where { + type T a; +} +instance C b => C Int where { + type T Int = Bool; +} addfile ./tests/well-formed/should_fail/constraining_unbound_var3.err hunk ./tests/well-formed/should_fail/constraining_unbound_var3.err 1 +type variable `a' does not exist addfile ./tests/well-formed/should_fail/constraining_unbound_var3.mhs hunk ./tests/well-formed/should_fail/constraining_unbound_var3.mhs 1 +class C a where {} + +foo :: C a => Int; +foo = 42; addfile ./tests/well-formed/should_fail/cyclic_class_hierarchy.err hunk ./tests/well-formed/should_fail/cyclic_class_hierarchy.err 1 +cyclic class hierarchy: [C1,C3,C2] addfile ./tests/well-formed/should_fail/cyclic_class_hierarchy.mhs hunk ./tests/well-formed/should_fail/cyclic_class_hierarchy.mhs 1 +class C3 a => C1 a where { +} + +class C1 a => C2 a where { +} + +class C2 a => C3 a where { +} addfile ./tests/well-formed/should_fail/eq_constraint1.err hunk ./tests/well-formed/should_fail/eq_constraint1.err 1 +invalid associated type synonym `T' in equality constraint (first parameter is not a variable) addfile ./tests/well-formed/should_fail/eq_constraint1.mhs hunk ./tests/well-formed/should_fail/eq_constraint1.mhs 1 +class C a where { + type T a b; +} + +foo :: T Int a = Bool => a -> Bool; +foo x = False; addfile ./tests/well-formed/should_fail/eq_constraint2.err hunk ./tests/well-formed/should_fail/eq_constraint2.err 1 +invalid associated type synonym `T' in equality constraint (first parameter is not a variable) addfile ./tests/well-formed/should_fail/eq_constraint2.mhs hunk ./tests/well-formed/should_fail/eq_constraint2.mhs 1 +class C a where { + type T a b; +} + +class D b where { + foo :: T Int a = Bool => a -> b -> Bool; +} addfile ./tests/well-formed/should_fail/eq_constraint3.err hunk ./tests/well-formed/should_fail/eq_constraint3.err 1 +invalid associated type synonym `T' in equality constraint (first parameter is not a variable) addfile ./tests/well-formed/should_fail/eq_constraint3.mhs hunk ./tests/well-formed/should_fail/eq_constraint3.mhs 1 +class C a where { + type T a b; +} + +bar x = letrec foo :: T Int a = Bool => a -> b -> Bool; + foo x y = True; + in 42; addfile ./tests/well-formed/should_fail/eq_constraint4.err hunk ./tests/well-formed/should_fail/eq_constraint4.err 1 +invalid associated type synonym `T' in equality constraint (first parameter is not a variable) addfile ./tests/well-formed/should_fail/eq_constraint4.mhs hunk ./tests/well-formed/should_fail/eq_constraint4.mhs 1 +class C a where { + type T a b; +} + +data D a = D a; + +instance T Int a = Bool => C (D a) where { + type T (D a) b = Int; +} addfile ./tests/well-formed/should_fail/illegal_assoc_decl1.err hunk ./tests/well-formed/should_fail/illegal_assoc_decl1.err 1 +illegal class declaration addfile ./tests/well-formed/should_fail/illegal_assoc_decl1.mhs hunk ./tests/well-formed/should_fail/illegal_assoc_decl1.mhs 1 +class C a b where { + type T b a; +} addfile ./tests/well-formed/should_fail/illegal_assoc_decl2.err hunk ./tests/well-formed/should_fail/illegal_assoc_decl2.err 1 +illegal class declaration addfile ./tests/well-formed/should_fail/illegal_assoc_decl2.mhs hunk ./tests/well-formed/should_fail/illegal_assoc_decl2.mhs 1 +class C a b where { + type T a c b; +} addfile ./tests/well-formed/should_fail/illegal_class_constraint.err hunk ./tests/well-formed/should_fail/illegal_class_constraint.err 1 +illegal context for class D: only type variables can be constrained addfile ./tests/well-formed/should_fail/illegal_class_constraint.mhs hunk ./tests/well-formed/should_fail/illegal_class_constraint.mhs 1 +class C a where { +} + +class C Int => D a where { +} addfile ./tests/well-formed/should_fail/illegal_instance_constraint1.err hunk ./tests/well-formed/should_fail/illegal_instance_constraint1.err 1 +illegal constraint in instance declaration for class C: C Int addfile ./tests/well-formed/should_fail/illegal_instance_constraint1.mhs hunk ./tests/well-formed/should_fail/illegal_instance_constraint1.mhs 1 +class C a where { + type T a; +} + +instance C Int => C Bool where { + type T Bool = Int; +} addfile ./tests/well-formed/should_fail/illegal_instance_constraint2.err hunk ./tests/well-formed/should_fail/illegal_instance_constraint2.err 1 +illegal constraint in instance declaration for class C: T a[2] = a[2] addfile ./tests/well-formed/should_fail/illegal_instance_constraint2.mhs hunk ./tests/well-formed/should_fail/illegal_instance_constraint2.mhs 1 +data D a = DC a; + +class C a where { + type T a; +} + +instance C Int where { + type T Int = Int; +} + +instance C a, T a = a => C (D a) where { + type T (D a) = Bool; +} addfile ./tests/well-formed/should_fail/illegal_instance_constraint3.err hunk ./tests/well-formed/should_fail/illegal_instance_constraint3.err 1 +illegal constraint in instance declaration for class C: T a[2] = T Int addfile ./tests/well-formed/should_fail/illegal_instance_constraint3.mhs hunk ./tests/well-formed/should_fail/illegal_instance_constraint3.mhs 1 +data D a = DC a; + +class C a where { + type T a; +} + +instance C Int where { + type T Int = Int; +} + +instance C a, T a = T Int => C (D a) where { + type T (D a) = Bool; +} addfile ./tests/well-formed/should_fail/illegal_instance_head.err hunk ./tests/well-formed/should_fail/illegal_instance_head.err 1 +duplicate type variable in head of instance for class C addfile ./tests/well-formed/should_fail/illegal_instance_head.mhs hunk ./tests/well-formed/should_fail/illegal_instance_head.mhs 1 +data D a b = D a b; + +class C a where { + type T a; +} + +instance C (D a a) where { + type T (D a a) = Int; +} addfile ./tests/well-formed/should_fail/instance_for_tyvar.err hunk ./tests/well-formed/should_fail/instance_for_tyvar.err 1 +illegal instance declaration for class C: single type variable not allowed in instance head addfile ./tests/well-formed/should_fail/instance_for_tyvar.mhs hunk ./tests/well-formed/should_fail/instance_for_tyvar.mhs 1 - +class C a where { + type T a; +} + +instance C a where { + type T a = Int; +} addfile ./tests/well-formed/should_fail/list-not-working.sh hunk ./tests/well-formed/should_fail/list-not-working.sh 1 +#!/bin/sh + +for x in `ls *.mhs` ; do + if [ ! -e ${x%.mhs}.err ] ; then + echo $x + fi +done addfile ./tests/well-formed/should_fail/missing_assoc_type.err hunk ./tests/well-formed/should_fail/missing_assoc_type.err 1 +illegal instance declaration for class C: type synonyms do not match addfile ./tests/well-formed/should_fail/missing_assoc_type.mhs hunk ./tests/well-formed/should_fail/missing_assoc_type.mhs 1 +class C a where { + type S a; + type T a; +} + +instance C Int where { + type S Int = Bool; +} addfile ./tests/well-formed/should_fail/missing_assoc_type2.err hunk ./tests/well-formed/should_fail/missing_assoc_type2.err 1 +Parser error, next tokens: + line 12:3, ReservedIdT "type" + line 12:8, ConIdT "U" + line 12:10, ConIdT "Int" addfile ./tests/well-formed/should_fail/missing_assoc_type2.mhs hunk ./tests/well-formed/should_fail/missing_assoc_type2.mhs 1 +class D a where { + type U a; +} + +class C a where { + type S a; + type T a; +} + +instance C Int where { + type S Int = Bool; + type U Int = Bool; +} addfile ./tests/well-formed/should_fail/missing_method.err hunk ./tests/well-formed/should_fail/missing_method.err 1 +illegal instance declaration for class C: methods do not match addfile ./tests/well-formed/should_fail/missing_method.mhs hunk ./tests/well-formed/should_fail/missing_method.mhs 1 +class C a where { + type T a; + foo :: a; +} + +instance C Int where { + type T Int = Bool; +} addfile ./tests/well-formed/should_fail/missing_method2.err hunk ./tests/well-formed/should_fail/missing_method2.err 1 +illegal instance declaration for class C: methods do not match addfile ./tests/well-formed/should_fail/missing_method2.mhs hunk ./tests/well-formed/should_fail/missing_method2.mhs 1 +class D a where { + bar :: a; +} + +class C a where { + type T a; + foo :: a; +} + +instance C Int where { + type T Int = Bool; + bar = 4; +} addfile ./tests/well-formed/should_fail/not_decreasing.err hunk ./tests/well-formed/should_fail/not_decreasing.err 1 +Definition of associated type synonym T is not decreasing. Number of data constructors in definition head: 1. Number of data constructors on the right side: 1 addfile ./tests/well-formed/should_fail/not_decreasing.mhs hunk ./tests/well-formed/should_fail/not_decreasing.mhs 1 +class C a where { + type T a; +} + +instance C Int where { + type T Int = Bool; +} + +instance C Bool where { + type T Bool = T Int; +} + addfile ./tests/well-formed/should_fail/not_left_linear.err hunk ./tests/well-formed/should_fail/not_left_linear.err 1 +duplicate type variable in head of instance for class C addfile ./tests/well-formed/should_fail/not_left_linear.mhs hunk ./tests/well-formed/should_fail/not_left_linear.mhs 1 - +data D a b = DC a b; + +class C a where { + type T a; +} + +instance C (D a a) where { + type T (D a a) = Int; +} addfile ./tests/well-formed/should_fail/not_linear_in_args.err hunk ./tests/well-formed/should_fail/not_linear_in_args.err 1 +Definition of associated type synonym T contains a non-linear type synonym application addfile ./tests/well-formed/should_fail/not_linear_in_args.mhs hunk ./tests/well-formed/should_fail/not_linear_in_args.mhs 1 - +data D1 a b = D1C a b; +data D2 a b = D2C a b; + +class C a where { + type T a; +} + +instance C (D1 a b) where { + type T (D1 a b) = Int; +} + +instance C (D2 a Int) where { + type T (D2 a Int) = T (D1 a a); +} addfile ./tests/well-formed/should_fail/not_repeating_params.err hunk ./tests/well-formed/should_fail/not_repeating_params.err 1 +definiton of associated type synonym must repeat the type of the instance head addfile ./tests/well-formed/should_fail/not_repeating_params.mhs hunk ./tests/well-formed/should_fail/not_repeating_params.mhs 1 +class C a where { + type T a; +} + +instance C Int where { + type T Bool = Int; +} addfile ./tests/well-formed/should_fail/not_saturated1.err hunk ./tests/well-formed/should_fail/not_saturated1.err 1 +application `CT b[2]' of associated type synonym is not saturated addfile ./tests/well-formed/should_fail/not_saturated1.mhs hunk ./tests/well-formed/should_fail/not_saturated1.mhs 1 +class C a where { + type CT a b; +} + +instance C Int where { + type CT Int b = Bool; +} + +instance C Bool where { + type CT Bool b = CT b; +} + addfile ./tests/well-formed/should_fail/not_saturated2.err hunk ./tests/well-formed/should_fail/not_saturated2.err 1 +application `CT a[2]' of associated type synonym is not saturated addfile ./tests/well-formed/should_fail/not_saturated2.mhs hunk ./tests/well-formed/should_fail/not_saturated2.mhs 1 - +class C a where { + type CT a b; +} + +data D a = D a; + +instance CT a = Int => C (D a) where { + type CT (D a) b = Bool; +} addfile ./tests/well-formed/should_fail/not_saturated3.err hunk ./tests/well-formed/should_fail/not_saturated3.err 1 +application `T b[1]' of associated type synonym is not saturated addfile ./tests/well-formed/should_fail/not_saturated3.mhs hunk ./tests/well-formed/should_fail/not_saturated3.mhs 1 +class C a where { + type T a b; +} + +data D a = D a; + +instance C Int where { + type T Int b = T b; +} + +foo :: T Int; +foo = D 42; addfile ./tests/well-formed/should_fail/overlapping.err hunk ./tests/well-formed/should_fail/overlapping.err 1 +overlapping instances for class C addfile ./tests/well-formed/should_fail/overlapping.mhs hunk ./tests/well-formed/should_fail/overlapping.mhs 1 +class C a where { + type T a; +} + +data D a = D a; + +instance C (D a) where { + type T (D a) = Int; +} + +instance C (D Int) where { + type T (D Int) = Bool; +} addfile ./tests/well-formed/should_fail/param_number_not_ok.err hunk ./tests/well-formed/should_fail/param_number_not_ok.err 1 +wrong number of arguments in definition of associated type synonym T addfile ./tests/well-formed/should_fail/param_number_not_ok.mhs hunk ./tests/well-formed/should_fail/param_number_not_ok.mhs 1 - +class C a where { + type T a b; +} + +instance C Int where { + type T Int a c = Bool; +} }