From f607aa57db723cf072bfd3146df9dcb8020b3168 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Wed, 26 Aug 2020 10:09:17 +0200 Subject: [PATCH 001/120] Implement first part of Normalform instance generator #150 During the conversion of a data declaration, a Normalform instance will be generated. This commit implements a part of that generator that generates most of the nf' function. The resulting code is not yet valid because the type signature is still missing, but if the type signature is added manually, the generated code is valid. We are able to consider types with nested recursion and mutually recursive types, but I have not considered type synonyms yet. That will also be added later. --- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 509 ++++++++++++------ 1 file changed, 352 insertions(+), 157 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 21699d79..a54d0a89 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -1,48 +1,52 @@ -- | This module contains functions for converting type synonym and data type -- declarations and their constructors. - module FreeC.Backend.Coq.Converter.TypeDecl where -import Control.Monad ( mapAndUnzipM ) -import Control.Monad.Extra ( concatMapM ) -import Data.List ( partition ) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe ( catMaybes ) -import qualified Data.Set as Set - -import qualified FreeC.Backend.Coq.Syntax as Coq -import FreeC.Backend.Coq.Converter.Arg -import FreeC.Backend.Coq.Converter.Free -import FreeC.Backend.Coq.Converter.Type -import qualified FreeC.Backend.Coq.Base as Coq.Base -import FreeC.Environment -import FreeC.IR.DependencyGraph -import qualified FreeC.IR.Syntax as IR -import FreeC.IR.TypeSynExpansion -import FreeC.Monad.Converter -import FreeC.Monad.Reporter -import FreeC.Pretty +import Control.Monad ( mapAndUnzipM, foldM, replicateM ) +import Control.Monad.Extra ( concatMapM ) +import Data.List ( partition, nub, intercalate ) -- TODO: Remove intercalate +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe ( catMaybes, fromJust ) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified FreeC.Backend.Coq.Syntax as Coq +import FreeC.Backend.Coq.Converter.Arg +import FreeC.Backend.Coq.Converter.Free +import FreeC.Backend.Coq.Converter.Type +import qualified FreeC.Backend.Coq.Base as Coq.Base +import FreeC.Environment +import FreeC.Environment.Entry +import FreeC.Environment.LookupOrFail +import FreeC.Environment.Fresh +import FreeC.IR.DependencyGraph +import FreeC.IR.Subst +import qualified FreeC.IR.Syntax as IR +import FreeC.IR.TypeSynExpansion +import FreeC.IR.Unification +import FreeC.Monad.Converter +import FreeC.Monad.Reporter +import FreeC.Pretty +import FreeC.IR.SrcSpan ( SrcSpan(NoSrcSpan) ) ------------------------------------------------------------------------------- -- Strongly connected components -- ------------------------------------------------------------------------------- - -- | Converts a strongly connected component of the type dependency graph. convertTypeComponent - :: DependencyComponent IR.TypeDecl -> Converter [Coq.Sentence] + :: DependencyComponent IR.TypeDecl -> Converter [ Coq.Sentence ] convertTypeComponent (NonRecursive decl) - | isTypeSynDecl decl = convertTypeSynDecl decl - | otherwise = convertDataDecls [decl] + | isTypeSynDecl decl = convertTypeSynDecl decl + | otherwise = convertDataDecls [ decl ] convertTypeComponent (Recursive decls) = do - let (typeSynDecls, dataDecls) = partition isTypeSynDecl decls - typeSynDeclQNames = Set.fromList (map IR.typeDeclQName typeSynDecls) - sortedTypeSynDecls <- sortTypeSynDecls typeSynDecls - expandedDataDecls <- mapM - (expandAllTypeSynonymsInDeclWhere (`Set.member` typeSynDeclQNames)) - dataDecls - dataDecls' <- convertDataDecls expandedDataDecls - typeSynDecls' <- concatMapM convertTypeSynDecl sortedTypeSynDecls - return (dataDecls' ++ typeSynDecls') + let ( typeSynDecls, dataDecls ) = partition isTypeSynDecl decls + typeSynDeclQNames = Set.fromList (map IR.typeDeclQName typeSynDecls) + sortedTypeSynDecls <- sortTypeSynDecls typeSynDecls + expandedDataDecls <- mapM + (expandAllTypeSynonymsInDeclWhere (`Set.member` typeSynDeclQNames)) + dataDecls + dataDecls' <- convertDataDecls expandedDataDecls + typeSynDecls' <- concatMapM convertTypeSynDecl sortedTypeSynDecls + return (dataDecls' ++ typeSynDecls') -- | Sorts type synonym declarations topologically. -- @@ -51,7 +55,7 @@ convertTypeComponent (Recursive decls) = do -- if they form a cycle). However, type synonyms may still depend on other -- type synonyms from the same strongly connected component. Therefore we -- have to sort the declarations in reverse topological order. -sortTypeSynDecls :: [IR.TypeDecl] -> Converter [IR.TypeDecl] +sortTypeSynDecls :: [ IR.TypeDecl ] -> Converter [ IR.TypeDecl ] sortTypeSynDecls = mapM fromNonRecursive . groupTypeDecls -- | Extracts the single type synonym declaration from a strongly connected @@ -61,44 +65,38 @@ sortTypeSynDecls = mapM fromNonRecursive . groupTypeDecls -- declarations (i.e. type synonyms form a cycle). fromNonRecursive :: DependencyComponent IR.TypeDecl -> Converter IR.TypeDecl fromNonRecursive (NonRecursive decl) = return decl -fromNonRecursive (Recursive decls) = - reportFatal - $ Message (IR.typeDeclSrcSpan (head decls)) Error - $ "Type synonym declarations form a cycle: " - ++ showPretty (map IR.typeDeclIdent decls) +fromNonRecursive (Recursive decls) = reportFatal $ Message + (IR.typeDeclSrcSpan (head decls)) Error + $ "Type synonym declarations form a cycle: " ++ showPretty + (map IR.typeDeclIdent decls) ------------------------------------------------------------------------------- -- Type synonym declarations -- ------------------------------------------------------------------------------- - -- | Tests whether the given declaration is a type synonym declaration. isTypeSynDecl :: IR.TypeDecl -> Bool isTypeSynDecl (IR.TypeSynDecl _ _ _ _) = True -isTypeSynDecl (IR.DataDecl _ _ _ _) = False +isTypeSynDecl (IR.DataDecl _ _ _ _) = False -- | Converts a Haskell type synonym declaration to Coq. -convertTypeSynDecl :: IR.TypeDecl -> Converter [Coq.Sentence] -convertTypeSynDecl decl@(IR.TypeSynDecl _ _ typeVarDecls typeExpr) = - localEnv $ do - let name = IR.typeDeclQName decl - Just qualid <- inEnv $ lookupIdent IR.TypeScope name - typeVarDecls' <- convertTypeVarDecls Coq.Explicit typeVarDecls - typeExpr' <- convertType' typeExpr - return - [ Coq.definitionSentence qualid - (genericArgDecls Coq.Explicit ++ typeVarDecls') - (Just Coq.sortType) - typeExpr' - ] - +convertTypeSynDecl :: IR.TypeDecl -> Converter [ Coq.Sentence ] +convertTypeSynDecl decl@(IR.TypeSynDecl _ _ typeVarDecls typeExpr) + = localEnv $ do + let name = IR.typeDeclQName decl + Just qualid <- inEnv $ lookupIdent IR.TypeScope name + typeVarDecls' <- convertTypeVarDecls Coq.Explicit typeVarDecls + typeExpr' <- convertType' typeExpr + return [ Coq.definitionSentence qualid + (genericArgDecls Coq.Explicit ++ typeVarDecls') + (Just Coq.sortType) typeExpr' + ] -- Data type declarations are not allowed in this function. -convertTypeSynDecl (IR.DataDecl _ _ _ _) = - error "convertTypeSynDecl: Data type declaration not allowed." +convertTypeSynDecl (IR.DataDecl _ _ _ _) + = error "convertTypeSynDecl: Data type declaration not allowed." ------------------------------------------------------------------------------- -- Data type declarations -- ------------------------------------------------------------------------------- - -- | Converts multiple (mutually recursive) Haskell data type declaration -- declarations. -- @@ -112,17 +110,15 @@ convertTypeSynDecl (IR.DataDecl _ _ _ _) = -- After the @Inductive@ sentences for the data type declarations there -- is one @Arguments@ sentence and one smart constructor declaration for -- each constructor declaration of the given data types. -convertDataDecls :: [IR.TypeDecl] -> Converter [Coq.Sentence] +convertDataDecls :: [ IR.TypeDecl ] -> Converter [ Coq.Sentence ] convertDataDecls dataDecls = do - (indBodies, extraSentences) <- mapAndUnzipM convertDataDecl dataDecls - return - ( Coq.comment - ( "Data type declarations for " - ++ showPretty (map IR.typeDeclName dataDecls) - ) - : Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList indBodies) []) - : concat extraSentences - ) + ( indBodies, extraSentences ) <- mapAndUnzipM convertDataDecl dataDecls + instances <- generateInstances dataDecls + return + (Coq.comment ("Data type declarations for " ++ showPretty + (map IR.typeDeclName dataDecls)) : Coq.InductiveSentence + (Coq.Inductive (NonEmpty.fromList indBodies) []) + : concat extraSentences ++ instances) -- | Converts a Haskell data type declaration to the body of a Coq @Inductive@ -- sentence, the @Arguments@ sentences for it's constructors and the smart @@ -130,94 +126,293 @@ convertDataDecls dataDecls = do -- -- Type variables declared by the data type or the smart constructors are -- not visible outside of this function. -convertDataDecl :: IR.TypeDecl -> Converter (Coq.IndBody, [Coq.Sentence]) -convertDataDecl (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = - do - (body, argumentsSentences) <- generateBodyAndArguments - smartConDecls <- mapM generateSmartConDecl conDecls - return - ( body - , Coq.comment - ("Arguments sentences for " ++ showPretty (IR.toUnQual name)) - : argumentsSentences - ++ Coq.comment - ("Smart constructors for " ++ showPretty (IR.toUnQual name)) - : smartConDecls - ) - where - -- | Generates the body of the @Inductive@ sentence and the @Arguments@ - -- sentences for the constructors but not the smart constructors - -- of the data type. - -- - -- Type variables declared by the data type declaration are visible to the - -- constructor declarations and @Arguments@ sentences created by this - -- function, but not outside this function. This allows the smart - -- constructors to reuse the identifiers for their type arguments (see - -- 'generateSmartConDecl'). - generateBodyAndArguments :: Converter (Coq.IndBody, [Coq.Sentence]) - generateBodyAndArguments = localEnv $ do - Just qualid <- inEnv $ lookupIdent IR.TypeScope name - typeVarDecls' <- convertTypeVarDecls Coq.Explicit typeVarDecls - conDecls' <- mapM convertConDecl conDecls - argumentsSentences <- mapM generateArgumentsSentence conDecls - return - ( Coq.IndBody qualid - (genericArgDecls Coq.Explicit ++ typeVarDecls') - Coq.sortType - conDecls' - , argumentsSentences - ) - - -- | Converts a constructor of the data type. - convertConDecl - :: IR.ConDecl -> Converter (Coq.Qualid, [Coq.Binder], Maybe Coq.Term) - convertConDecl (IR.ConDecl _ (IR.DeclIdent _ conName) args) = do - Just conQualid <- inEnv $ lookupIdent IR.ValueScope conName - Just returnType <- inEnv $ lookupReturnType IR.ValueScope conName - args' <- mapM convertType args - returnType' <- convertType' returnType - return (conQualid, [], Just (args' `Coq.arrows` returnType')) - - -- | Generates the @Arguments@ sentence for the given constructor declaration. - generateArgumentsSentence :: IR.ConDecl -> Converter Coq.Sentence - generateArgumentsSentence (IR.ConDecl _ (IR.DeclIdent _ conName) _) = do - Just qualid <- inEnv $ lookupIdent IR.ValueScope conName - let typeVarNames = map IR.typeVarDeclQName typeVarDecls - typeVarQualids <- mapM (inEnv . lookupIdent IR.TypeScope) typeVarNames - return - (Coq.ArgumentsSentence - (Coq.Arguments - Nothing - qualid - [ Coq.ArgumentSpec Coq.ArgMaximal (Coq.Ident typeVarQualid) Nothing - | typeVarQualid <- map fst Coq.Base.freeArgs - ++ catMaybes typeVarQualids - ] - ) - ) - - -- | Generates the smart constructor declaration for the given constructor - -- declaration. - generateSmartConDecl :: IR.ConDecl -> Converter Coq.Sentence - generateSmartConDecl (IR.ConDecl _ declIdent argTypes) = localEnv $ do - let conName = IR.declIdentName declIdent - Just qualid <- inEnv $ lookupIdent IR.ValueScope conName - Just smartQualid <- inEnv $ lookupSmartIdent conName - Just returnType <- inEnv $ lookupReturnType IR.ValueScope conName - typeVarDecls' <- convertTypeVarDecls Coq.Implicit typeVarDecls - (argIdents', argDecls') <- mapAndUnzipM convertAnonymousArg - (map Just argTypes) - returnType' <- convertType returnType - rhs <- generatePure - (Coq.app (Coq.Qualid qualid) (map Coq.Qualid argIdents')) - return - (Coq.definitionSentence - smartQualid - (genericArgDecls Coq.Explicit ++ typeVarDecls' ++ argDecls') - (Just returnType') - rhs - ) +convertDataDecl :: IR.TypeDecl -> Converter ( Coq.IndBody, [ Coq.Sentence ] ) +convertDataDecl (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do + ( body, argumentsSentences ) <- generateBodyAndArguments + smartConDecls <- mapM generateSmartConDecl conDecls + return ( body + , Coq.comment ("Arguments sentences for " ++ showPretty + (IR.toUnQual name)) : argumentsSentences + ++ Coq.comment ("Smart constructors for " ++ showPretty + (IR.toUnQual name)) : smartConDecls + ) + where + -- | Generates the body of the @Inductive@ sentence and the @Arguments@ + -- sentences for the constructors but not the smart constructors + -- of the data type. + -- + -- Type variables declared by the data type declaration are visible to the + -- constructor declarations and @Arguments@ sentences created by this + -- function, but not outside this function. This allows the smart + -- constructors to reuse the identifiers for their type arguments (see + -- 'generateSmartConDecl'). + generateBodyAndArguments :: Converter ( Coq.IndBody, [ Coq.Sentence ] ) + generateBodyAndArguments = localEnv $ do + Just qualid <- inEnv $ lookupIdent IR.TypeScope name + typeVarDecls' <- convertTypeVarDecls Coq.Explicit typeVarDecls + conDecls' <- mapM convertConDecl conDecls + argumentsSentences <- mapM generateArgumentsSentence conDecls + return + ( Coq.IndBody qualid (genericArgDecls Coq.Explicit ++ typeVarDecls') + Coq.sortType conDecls' + , argumentsSentences + ) + + -- | Converts a constructor of the data type. + convertConDecl :: IR.ConDecl + -> Converter ( Coq.Qualid, [ Coq.Binder ], Maybe Coq.Term ) + convertConDecl (IR.ConDecl _ (IR.DeclIdent _ conName) args) = do + Just conQualid <- inEnv $ lookupIdent IR.ValueScope conName + Just returnType <- inEnv $ lookupReturnType IR.ValueScope conName + args' <- mapM convertType args + returnType' <- convertType' returnType + return ( conQualid, [], Just (args' `Coq.arrows` returnType') ) + -- | Generates the @Arguments@ sentence for the given constructor declaration. + generateArgumentsSentence :: IR.ConDecl -> Converter Coq.Sentence + generateArgumentsSentence (IR.ConDecl _ (IR.DeclIdent _ conName) _) = do + Just qualid <- inEnv $ lookupIdent IR.ValueScope conName + let typeVarNames = map IR.typeVarDeclQName typeVarDecls + typeVarQualids <- mapM (inEnv . lookupIdent IR.TypeScope) typeVarNames + return (Coq.ArgumentsSentence + (Coq.Arguments Nothing qualid + [ Coq.ArgumentSpec Coq.ArgMaximal (Coq.Ident typeVarQualid) + Nothing | typeVarQualid + <- map fst Coq.Base.freeArgs ++ catMaybes typeVarQualids + ])) + + -- | Generates the smart constructor declaration for the given constructor + -- declaration. + generateSmartConDecl :: IR.ConDecl -> Converter Coq.Sentence + generateSmartConDecl (IR.ConDecl _ declIdent argTypes) = localEnv $ do + let conName = IR.declIdentName declIdent + Just qualid <- inEnv $ lookupIdent IR.ValueScope conName + Just smartQualid <- inEnv $ lookupSmartIdent conName + Just returnType <- inEnv $ lookupReturnType IR.ValueScope conName + typeVarDecls' <- convertTypeVarDecls Coq.Implicit typeVarDecls + ( argIdents', argDecls' ) <- mapAndUnzipM convertAnonymousArg + (map Just argTypes) + returnType' <- convertType returnType + rhs <- generatePure + (Coq.app (Coq.Qualid qualid) (map Coq.Qualid argIdents')) + return (Coq.definitionSentence smartQualid + (genericArgDecls Coq.Explicit ++ typeVarDecls' ++ argDecls') + (Just returnType') rhs) -- Type synonyms are not allowed in this function. -convertDataDecl (IR.TypeSynDecl _ _ _ _) = - error "convertDataDecl: Type synonym not allowed." +convertDataDecl (IR.TypeSynDecl _ _ _ _) + = error "convertDataDecl: Type synonym not allowed." + +------ Instance generation ------- +generateInstances :: [ IR.TypeDecl ] -> Converter [ Coq.Sentence ] +generateInstances dataDecls = do + nfInstances <- generateNormalformInstances + return [ nfInstances ] + where + declTypes = map dataDeclToType dataDecls + + generateNormalformInstances :: Converter Coq.Sentence + generateNormalformInstances = generateNf' dataDecls declTypes + + generateNf' :: [ IR.TypeDecl ] -> [ IR.Type ] -> Converter Coq.Sentence + generateNf' dataDecls declTypes = do + topLevelMap <- nameFunctions "nf'" emptyTypeMap declTypes + topLevelVars <- (map Coq.bare) <$> mapM freshCoqIdent + (replicate (length declTypes) "x") + rhss <- mapM (generateBody topLevelMap) + (zip3 topLevelVars dataDecls declTypes) + return $ Coq.FixpointSentence + (Coq.Fixpoint (NonEmpty.fromList + (map (makeFixBody topLevelMap) + (zip3 topLevelVars declTypes rhss))) []) -- curry? + where + conNames = (map IR.typeDeclQName dataDecls) + + makeFixBody + :: TypeMap -> ( Coq.Qualid, IR.Type, (Coq.Term,[Coq.Binder]) ) -> Coq.FixBody + makeFixBody m ( varName, typeName, (typeRhs,binders) ) = Coq.FixBody + (fromJust (lookupType typeName m)) + (NonEmpty.fromList + (binders ++ [ Coq.Inferred Coq.Explicit (Coq.Ident varName) ])) + Nothing Nothing typeRhs + + generateBody :: TypeMap -- turn this into a sort of general function that operates on a dataDecl and the other stuff it's already getting. The other functions (nf etc.) + -- can branch off from here because they also need the binders, types and stuff. Well, just the top-level types, actually. + -> ( Coq.Qualid, IR.TypeDecl, IR.Type ) -> Converter (Coq.Term, [Coq.Binder]) -- TODO: don't do that. Sort these functions properly. + generateBody topLevelMap ( ident, tDecl, t ) = do + let ts = nub (reverse (concatMap (collectSubTypes conNames) + (concatMap IR.conDeclFields + (IR.dataDeclCons tDecl)))) + let recTypes = filter + (\t -> not (t `elem` declTypes || isTypeVar t)) ts + let typeVars = map (Coq.bare . IR.typeVarDeclIdent) (IR.typeDeclArgs tDecl) + targetVars <- (map Coq.bare) <$> replicateM (length typeVars) (freshCoqIdent "b") + let freeQualids = map fst Coq.Base.freeArgs + let nfConstraints = map (buildConstraint "Normalform") (zipWith (\src trgt -> freeQualids ++ [src,trgt]) typeVars targetVars) + let binders = freeArgsBinders ++ typeBinder (typeVars ++ targetVars) : nfConstraints + normalformFuncMap <- nameFunctions "nf'" topLevelMap recTypes + nf'Body <- generateNf'Body normalformFuncMap ident t recTypes + return (nf'Body,binders) + + -- letfix distinction + generateNf'Body :: TypeMap + -> Coq.Qualid -> IR.Type -> [ IR.Type ] -> Converter Coq.Term + generateNf'Body m ident t [] = matchConstructors m ident t + generateNf'Body m ident t (recType : recTypes) = do + inBody <- generateNf'Body m ident t recTypes + var <- Coq.bare <$> freshCoqIdent "x" + letBody <- matchConstructors m var recType + let Just localFuncName = lookupType recType m + let binders = NonEmpty.fromList + [ (Coq.Inferred Coq.Explicit (Coq.Ident var)) ] + return $ Coq.Let localFuncName [] Nothing + (Coq.Fix (Coq.FixOne (Coq.FixBody localFuncName binders Nothing + Nothing letBody))) inBody + + matchConstructors + :: TypeMap -> Coq.Qualid -> IR.Type -> Converter Coq.Term + matchConstructors m ident t = do + let Just conName = getTypeConName t + entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName + equations <- mapM (buildEquation m t) (entryConsNames entry) + return $ Coq.match (Coq.Qualid ident) equations + + -- type: type expression for unification + -- consName : data constructor name of type + buildEquation :: TypeMap -> IR.Type -> IR.ConName -> Converter + Coq.Equation -- TODO: rename type args before unification + + buildEquation m t conName = do + conEntry <- lookupEntryOrFail NoSrcSpan IR.ValueScope conName + let retType = entryReturnType conEntry + let conIdent = entryIdent conEntry -- :: Qualid + conArgIdents <- (map Coq.bare) <$> replicateM (entryArity conEntry) + (freshCoqIdent "fx") + subst <- unifyOrFail NoSrcSpan t retType + let modArgTypes = map ((stripType conNames) . (applySubst subst)) + (entryArgTypes conEntry) + let lhs = Coq.ArgsPat conIdent (map Coq.QualidPat conArgIdents) + rhs <- buildNormalformValue m conIdent [] + (zip modArgTypes conArgIdents) + return $ Coq.equation lhs rhs + + -- TODO: Split into normal function and helper function because of the accumulator. + buildNormalformValue :: TypeMap -> Coq.Qualid -> [ Coq.Qualid ] + -> [ ( IR.Type, Coq.Qualid ) ] -> Converter Coq.Term + buildNormalformValue nameMap consName vals [] = return $ applyPure + (Coq.app (Coq.Qualid consName) + (map (applyPure . Coq.Qualid) (reverse vals))) + buildNormalformValue nameMap consName vals (( t, varName ) : consVars) + = case lookupType t nameMap of + Just funcName -> do + x <- Coq.bare <$> freshCoqIdent "x" + nx <- Coq.bare <$> freshCoqIdent "nx" + rhs <- buildNormalformValue nameMap consName (nx : vals) + consVars + let c = Coq.fun [ nx ] [ Nothing ] rhs + let c'' = applyBind (Coq.app (Coq.Qualid funcName) + [ (Coq.Qualid x) ]) c + return $ applyBind (Coq.Qualid varName) + (Coq.fun [ x ] [ Nothing ] c'') + Nothing -> do + nx <- Coq.bare <$> freshCoqIdent "nx" + rhs <- buildNormalformValue nameMap consName (nx : vals) + consVars + let cont = Coq.fun [ nx ] [ Nothing ] rhs + return $ applyBind (Coq.app (Coq.Qualid (Coq.bare "nf")) + [ (Coq.Qualid varName) ]) cont + +showPrettyType :: IR.Type -> Converter String +showPrettyType (IR.TypeVar _ varName) = return (showPretty varName) +showPrettyType (IR.TypeCon srcSpan conName) = do + entry <- lookupEntryOrFail srcSpan IR.TypeScope conName + let Just coqIdent = Coq.unpackQualid (entryIdent entry) + return coqIdent +showPrettyType (IR.TypeApp _ l r) = do + lPretty <- showPrettyType l + rPretty <- showPrettyType r + return (lPretty ++ rPretty) + +collectSubTypes = collectFullyAppliedTypes True + +collectFullyAppliedTypes :: Bool -> [ IR.ConName ] -> IR.Type -> [ IR.Type ] +collectFullyAppliedTypes fullApplication conNames t@(IR.TypeApp _ l r) + | fullApplication = stripType conNames t : collectFullyAppliedTypes False + conNames l ++ collectFullyAppliedTypes True conNames r + | otherwise = collectFullyAppliedTypes False conNames l + ++ collectFullyAppliedTypes True conNames r +collectFullyAppliedTypes _ conNames t = [] + +-- returns the same type with all 'don't care' types replaced by the variable "_" +stripType cs t = stripType' t cs False + +stripType' :: IR.Type -> [ IR.ConName ] -> Bool -> IR.Type +stripType' (IR.TypeVar _ _) names flag = IR.TypeVar NoSrcSpan "_" +stripType' (IR.TypeCon _ conName) names flag + | flag || conName `elem` names = IR.TypeCon NoSrcSpan conName + | otherwise = IR.TypeVar NoSrcSpan "_" +stripType' (IR.TypeApp _ l r) names flag = case stripType' r names False of + r'@(IR.TypeVar _ _) -> IR.TypeApp NoSrcSpan (stripType' l names flag) r' + r' -> IR.TypeApp NoSrcSpan (stripType' l names True) r' + +nameFunctions :: String -> TypeMap -> [ IR.Type ] -> Converter TypeMap +nameFunctions prefix m ts = localEnv $ foldM (nameFunction prefix) m ts + +-- Names a function based on a type while avoiding name clashes with other +-- identifiers. +nameFunction :: String -> TypeMap -> IR.Type -> Converter TypeMap +nameFunction prefix m t = do + prettyType <- showPrettyType t + name <- freshCoqIdent (prefix ++ prettyType) + return (insertType t (Coq.bare name) m) + +dataDeclToType :: IR.TypeDecl -> IR.Type +dataDeclToType dataDecl = IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) + (replicate (length (IR.typeDeclArgs dataDecl)) (IR.TypeVar NoSrcSpan "_")) + +isTypeVar :: IR.Type -> Bool +isTypeVar (IR.TypeVar _ _) = True +isTypeVar _ = False + +-- duplicate of CompletePatternPass +getTypeConName :: IR.Type -> Maybe IR.ConName +getTypeConName (IR.TypeCon _ conName) = Just conName +getTypeConName (IR.TypeApp _ l r) = getTypeConName l +getTypeConName _ = Nothing + +buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder +buildConstraint ident args = Coq.Generalized Coq.Implicit (Coq.app (Coq.Qualid (Coq.bare ident)) (map Coq.Qualid args)) + +freeArgsBinders :: [Coq.Binder] +freeArgsBinders = map (uncurry (Coq.typedBinder' Coq.Implicit)) Coq.Base.freeArgs + +typeBinder :: [Coq.Qualid] -> Coq.Binder +typeBinder typeVars = Coq.typedBinder Coq.Implicit typeVars Coq.sortType + +generateNf :: Coq.Qualid -> Converter Coq.Sentence +generateNf typeName = undefined + +generateNfPure :: Coq.Qualid -> Converter [ Coq.Sentence ] +generateNfPure typeName = undefined + +generateNfImpure :: Coq.Qualid -> Converter [ Coq.Sentence ] +generateNfImpure typeName = undefined + +generateInstance :: Coq.Qualid -> Converter Coq.Sentence +generateInstance typeName = undefined + +-- TODO: Does this exist somewhere? +applyPure :: Coq.Term -> Coq.Term +applyPure t = Coq.app (Coq.Qualid Coq.Base.freePureCon) [ t ] + +applyBind :: Coq.Term -> Coq.Term -> Coq.Term +applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [ mx, f ] + +type TypeMap = IR.Type -> Maybe Coq.Qualid + +emptyTypeMap = const Nothing + +lookupType :: IR.Type -> TypeMap -> Maybe Coq.Qualid +lookupType = flip ($) + +insertType :: IR.Type -> Coq.Qualid -> TypeMap -> TypeMap +insertType k v m = \t -> if k == t then Just v else m t From b7350aa17c715bdb97f26d824eab0a9ed8353ce8 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Wed, 26 Aug 2020 19:14:52 +0200 Subject: [PATCH 002/120] Generate full Normalform instances #150 --- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 159 ++++++++++++------ 1 file changed, 105 insertions(+), 54 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index a54d0a89..60247fc4 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -206,39 +206,50 @@ convertDataDecl (IR.TypeSynDecl _ _ _ _) generateInstances :: [ IR.TypeDecl ] -> Converter [ Coq.Sentence ] generateInstances dataDecls = do nfInstances <- generateNormalformInstances - return [ nfInstances ] + return nfInstances where declTypes = map dataDeclToType dataDecls + conNames = map IR.typeDeclQName dataDecls - generateNormalformInstances :: Converter Coq.Sentence - generateNormalformInstances = generateNf' dataDecls declTypes - - generateNf' :: [ IR.TypeDecl ] -> [ IR.Type ] -> Converter Coq.Sentence - generateNf' dataDecls declTypes = do - topLevelMap <- nameFunctions "nf'" emptyTypeMap declTypes - topLevelVars <- (map Coq.bare) <$> mapM freshCoqIdent + generateNormalformInstances :: Converter [Coq.Sentence] + generateNormalformInstances = do + topLevelMap <- nameFunctionsAndInsert "nf'" emptyTypeMap declTypes + topLevelVars <- map Coq.bare <$> mapM freshCoqIdent (replicate (length declTypes) "x") - rhss <- mapM (generateBody topLevelMap) - (zip3 topLevelVars dataDecls declTypes) + nf' <- generateNf' topLevelMap dataDecls declTypes topLevelVars + instances <- mapM (buildInstance topLevelMap) declTypes + return (nf' : instances) + + buildInstance :: TypeMap -> IR.Type -> Converter Coq.Sentence + buildInstance m t = do + -- nf' := nf'T + let instanceBody = (Coq.bare "nf'", Coq.Qualid (fromJust (lookupType t m))) + -- Get the binders and return type for the instance declaration + (binders,retType) <- makeNFInstanceBindersAndReturnType t + instanceName <- Coq.bare <$> nameFunction "Normalform" t + return $ Coq.InstanceSentence (Coq.InstanceDefinition instanceName binders retType [instanceBody] Nothing) + + generateNf' :: TypeMap -> [ IR.TypeDecl ] -> [ IR.Type ] -> [Coq.Qualid] -> Converter Coq.Sentence + generateNf' topLevelMap dataDecls declTypes topLevelVars = do + + + -- rhss <- mapM (generateBody topLevelMap) + -- (zip3 topLevelVars dataDecls declTypes) + fixBodies <- mapM (uncurry (uncurry (makeFixBody topLevelMap))) (zip (zip topLevelVars declTypes) dataDecls) return $ Coq.FixpointSentence - (Coq.Fixpoint (NonEmpty.fromList - (map (makeFixBody topLevelMap) - (zip3 topLevelVars declTypes rhss))) []) -- curry? + (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) where - conNames = (map IR.typeDeclQName dataDecls) - - makeFixBody - :: TypeMap -> ( Coq.Qualid, IR.Type, (Coq.Term,[Coq.Binder]) ) -> Coq.FixBody - makeFixBody m ( varName, typeName, (typeRhs,binders) ) = Coq.FixBody - (fromJust (lookupType typeName m)) - (NonEmpty.fromList - (binders ++ [ Coq.Inferred Coq.Explicit (Coq.Ident varName) ])) - Nothing Nothing typeRhs - - generateBody :: TypeMap -- turn this into a sort of general function that operates on a dataDecl and the other stuff it's already getting. The other functions (nf etc.) - -- can branch off from here because they also need the binders, types and stuff. Well, just the top-level types, actually. - -> ( Coq.Qualid, IR.TypeDecl, IR.Type ) -> Converter (Coq.Term, [Coq.Binder]) -- TODO: don't do that. Sort these functions properly. - generateBody topLevelMap ( ident, tDecl, t ) = do + + + makeFixBody :: TypeMap -> Coq.Qualid -> IR.Type -> IR.TypeDecl -> Converter Coq.FixBody + makeFixBody m var t decl = do + rhs <- generateBody m var decl t + (binders,retType) <- makeNFBindersAndReturnType' t var + return $ Coq.FixBody (fromJust (lookupType t m)) (NonEmpty.fromList binders ) Nothing (Just retType) rhs + + + generateBody :: TypeMap -> Coq.Qualid -> IR.TypeDecl -> IR.Type -> Converter Coq.Term -- TODO: don't do that. Sort these functions properly. + generateBody topLevelMap ident tDecl t = do let ts = nub (reverse (concatMap (collectSubTypes conNames) (concatMap IR.conDeclFields (IR.dataDeclCons tDecl)))) @@ -247,11 +258,9 @@ generateInstances dataDecls = do let typeVars = map (Coq.bare . IR.typeVarDeclIdent) (IR.typeDeclArgs tDecl) targetVars <- (map Coq.bare) <$> replicateM (length typeVars) (freshCoqIdent "b") let freeQualids = map fst Coq.Base.freeArgs - let nfConstraints = map (buildConstraint "Normalform") (zipWith (\src trgt -> freeQualids ++ [src,trgt]) typeVars targetVars) - let binders = freeArgsBinders ++ typeBinder (typeVars ++ targetVars) : nfConstraints - normalformFuncMap <- nameFunctions "nf'" topLevelMap recTypes + normalformFuncMap <- nameFunctionsAndInsert "nf'" topLevelMap recTypes nf'Body <- generateNf'Body normalformFuncMap ident t recTypes - return (nf'Body,binders) + return nf'Body -- letfix distinction generateNf'Body :: TypeMap @@ -261,12 +270,11 @@ generateInstances dataDecls = do inBody <- generateNf'Body m ident t recTypes var <- Coq.bare <$> freshCoqIdent "x" letBody <- matchConstructors m var recType + (binders,retType) <- makeNFBindersAndReturnType' recType var let Just localFuncName = lookupType recType m - let binders = NonEmpty.fromList - [ (Coq.Inferred Coq.Explicit (Coq.Ident var)) ] return $ Coq.Let localFuncName [] Nothing - (Coq.Fix (Coq.FixOne (Coq.FixBody localFuncName binders Nothing - Nothing letBody))) inBody + (Coq.Fix (Coq.FixOne (Coq.FixBody localFuncName (NonEmpty.fromList binders) Nothing + (Just retType) letBody))) inBody matchConstructors :: TypeMap -> Coq.Qualid -> IR.Type -> Converter Coq.Term @@ -332,6 +340,7 @@ showPrettyType (IR.TypeApp _ l r) = do rPretty <- showPrettyType r return (lPretty ++ rPretty) +collectSubTypes :: [IR.ConName] -> IR.Type -> [IR.Type] collectSubTypes = collectFullyAppliedTypes True collectFullyAppliedTypes :: Bool -> [ IR.ConName ] -> IR.Type -> [ IR.Type ] @@ -354,16 +363,21 @@ stripType' (IR.TypeApp _ l r) names flag = case stripType' r names False of r'@(IR.TypeVar _ _) -> IR.TypeApp NoSrcSpan (stripType' l names flag) r' r' -> IR.TypeApp NoSrcSpan (stripType' l names True) r' -nameFunctions :: String -> TypeMap -> [ IR.Type ] -> Converter TypeMap -nameFunctions prefix m ts = localEnv $ foldM (nameFunction prefix) m ts +nameFunctionsAndInsert :: String -> TypeMap -> [ IR.Type ] -> Converter TypeMap +nameFunctionsAndInsert prefix m ts = localEnv $ foldM (nameFunctionAndInsert prefix) m ts + +nameFunctionAndInsert :: String -> TypeMap -> IR.Type -> Converter TypeMap +nameFunctionAndInsert prefix m t = do + name <- nameFunction prefix t + return (insertType t (Coq.bare name) m) -- Names a function based on a type while avoiding name clashes with other -- identifiers. -nameFunction :: String -> TypeMap -> IR.Type -> Converter TypeMap -nameFunction prefix m t = do +nameFunction :: String -> IR.Type -> Converter String +nameFunction prefix t = do prettyType <- showPrettyType t - name <- freshCoqIdent (prefix ++ prettyType) - return (insertType t (Coq.bare name) m) + freshCoqIdent (prefix ++ prettyType) + dataDeclToType :: IR.TypeDecl -> IR.Type dataDeclToType dataDecl = IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) @@ -380,26 +394,16 @@ getTypeConName (IR.TypeApp _ l r) = getTypeConName l getTypeConName _ = Nothing buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder -buildConstraint ident args = Coq.Generalized Coq.Implicit (Coq.app (Coq.Qualid (Coq.bare ident)) (map Coq.Qualid args)) +buildConstraint ident args = Coq.Generalized Coq.Implicit (Coq.app (Coq.Qualid (Coq.bare ident)) ((map (Coq.Qualid . fst) Coq.Base.freeArgs) ++ (map Coq.Qualid args))) + +-- Coq AST helper functions freeArgsBinders :: [Coq.Binder] freeArgsBinders = map (uncurry (Coq.typedBinder' Coq.Implicit)) Coq.Base.freeArgs typeBinder :: [Coq.Qualid] -> Coq.Binder typeBinder typeVars = Coq.typedBinder Coq.Implicit typeVars Coq.sortType -generateNf :: Coq.Qualid -> Converter Coq.Sentence -generateNf typeName = undefined - -generateNfPure :: Coq.Qualid -> Converter [ Coq.Sentence ] -generateNfPure typeName = undefined - -generateNfImpure :: Coq.Qualid -> Converter [ Coq.Sentence ] -generateNfImpure typeName = undefined - -generateInstance :: Coq.Qualid -> Converter Coq.Sentence -generateInstance typeName = undefined - -- TODO: Does this exist somewhere? applyPure :: Coq.Term -> Coq.Term applyPure t = Coq.app (Coq.Qualid Coq.Base.freePureCon) [ t ] @@ -407,8 +411,55 @@ applyPure t = Coq.app (Coq.Qualid Coq.Base.freePureCon) [ t ] applyBind :: Coq.Term -> Coq.Term -> Coq.Term applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [ mx, f ] +-- Given an A, returns Free Shape Pos A +applyFree :: Coq.Term -> Coq.Term +applyFree a = Coq.app (Coq.Qualid Coq.Base.free) ((map (Coq.Qualid . fst) Coq.Base.freeArgs) ++ [a]) + +-- converts our type into a Coq type (a term) with new variables for all don't care values +toCoqType :: String -> [Coq.Term] -> IR.Type -> Converter (Coq.Term, [Coq.Qualid]) +toCoqType varPrefix _ (IR.TypeVar _ _) = do + x <- Coq.bare <$> freshCoqIdent varPrefix + return (Coq.Qualid x, [x]) +toCoqType varPrefix shapeAndPos (IR.TypeCon _ conName) = do + entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName + return (Coq.app (Coq.Qualid (entryIdent entry)) shapeAndPos, [] ) +toCoqType varPrefix shapeAndPos (IR.TypeApp _ l r) = do + (l',varsl) <- toCoqType varPrefix shapeAndPos l + (r',varsr) <- toCoqType varPrefix shapeAndPos r + return (Coq.app l' [r'], varsl ++ varsr) + +makeNFBindersAndReturnType' :: IR.Type -> Coq.Qualid -> Converter ([Coq.Binder],Coq.Term) +makeNFBindersAndReturnType' t varName = do + (binders,sourceType,targetType) <- makeNFBindersAndReturnType t + let binders' = binders ++ [(Coq.typedBinder' Coq.Explicit varName sourceType)] + let retType = applyFree targetType + return (binders',retType) + +shapeAndPos :: [Coq.Term] +shapeAndPos = map (Coq.Qualid . fst) Coq.Base.freeArgs +idShapeAndPos :: [Coq.Term] +idShapeAndPos = (map (Coq.Qualid . Coq.bare) ["Identity.Shape", "Identity.Pos"]) + +makeNFInstanceBindersAndReturnType :: IR.Type -> Converter ([Coq.Binder], Coq.Term) +makeNFInstanceBindersAndReturnType t = do + (binders,sourceType,targetType) <- makeNFBindersAndReturnType t + let retType = Coq.app (Coq.Qualid (Coq.bare "Normalform")) (shapeAndPos ++ [sourceType,targetType]) + return (binders,retType) + + +-- makes appropriate binders and return type for a (possibly local) nf' function +makeNFBindersAndReturnType :: IR.Type -> Converter ([Coq.Binder],Coq.Term,Coq.Term) +makeNFBindersAndReturnType t = do + (sourceType,sourceVars) <- toCoqType "a" shapeAndPos t + (targetType,targetVars) <- toCoqType "b" idShapeAndPos t + let constraints = map (buildConstraint "Normalform") (zipWith (\v1 v2 -> [v1] ++ [v2]) sourceVars targetVars) + let binders = freeArgsBinders ++ [typeBinder (sourceVars ++ targetVars)] ++ constraints + return (binders,sourceType,targetType) + + type TypeMap = IR.Type -> Maybe Coq.Qualid +emptyTypeMap :: TypeMap emptyTypeMap = const Nothing lookupType :: IR.Type -> TypeMap -> Maybe Coq.Qualid From c998122221c9e4aa5e2a84fa186f7ea028263906 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Wed, 26 Aug 2020 19:28:13 +0200 Subject: [PATCH 003/120] Always export Identity #150 --- base/coq/Free.v | 1 + base/coq/Free/Instance/Identity.v | 4 ++-- base/coq/Free/Instance/Share.v | 3 ++- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/base/coq/Free.v b/base/coq/Free.v index b0422dd0..547590df 100644 --- a/base/coq/Free.v +++ b/base/coq/Free.v @@ -1,5 +1,6 @@ From Base Require Export Free.Class. From Base Require Export Free.ForFree. From Base Require Export Free.Induction. +From Base Require Export Free.Instance.Identity. From Base Require Export Free.Monad. From Base Require Export Free.Tactic.Simplify. \ No newline at end of file diff --git a/base/coq/Free/Instance/Identity.v b/base/coq/Free/Instance/Identity.v index ba9e2389..746877c0 100644 --- a/base/coq/Free/Instance/Identity.v +++ b/base/coq/Free/Instance/Identity.v @@ -1,7 +1,7 @@ (** * Definition of the identity monad in terms of the free monad. *) -From Base Require Import Free. -From Base Require Import Free.Instance.Comb. +From Base Require Import Free.Class.Injectable. +From Base Require Import Free.Monad. From Base Require Import Free.Util.Void. Module Identity. diff --git a/base/coq/Free/Instance/Share.v b/base/coq/Free/Instance/Share.v index 122b00a8..4aa28cab 100644 --- a/base/coq/Free/Instance/Share.v +++ b/base/coq/Free/Instance/Share.v @@ -1,6 +1,7 @@ (** * Definition of the sharing effect in terms of the free monad. *) -From Base Require Import Free. +From Base Require Import Free.Class.Injectable. +From Base Require Import Free.Monad. Module Share. From 95d7a97e9985a7da5fa2f00ad6a1f7e67633e5d4 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Wed, 26 Aug 2020 19:32:06 +0200 Subject: [PATCH 004/120] Clean up code a little #150 --- base/coq/Free/Class/Normalform.v | 31 ++-- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 160 ++++++++++-------- 2 files changed, 110 insertions(+), 81 deletions(-) diff --git a/base/coq/Free/Class/Normalform.v b/base/coq/Free/Class/Normalform.v index 897be0c8..178a94b8 100644 --- a/base/coq/Free/Class/Normalform.v +++ b/base/coq/Free/Class/Normalform.v @@ -5,17 +5,28 @@ From Base Require Import Free.Monad. -Class Normalform {Shape : Type} {Pos : Shape -> Type} +Class Normalform (Shape : Type) (Pos : Shape -> Type) (A B : Type) := { (** The function is split into two parts due to termination check errors for recursive data types. *) - nf : Free Shape Pos A -> Free Shape Pos B; - nf' : A -> Free Shape Pos B; - (** Property for moving nf into position functions *) - nf_impure: forall s (pf : _ -> Free Shape Pos A), - nf (impure s pf) = impure s (fun p => nf (pf p)); - (** Property for unfolding nf on pure values *) - nf_pure : forall (x : A), - nf (pure x) = nf' x - }. \ No newline at end of file + nf' : A -> Free Shape Pos B + }. + +Definition nf {Shape : Type} {Pos : Shape -> Type} {A B : Type} + `{Normalform Shape Pos A B} (n : Free Shape Pos A) + : Free Shape Pos B +:= n >>= nf'. + +Lemma nfImpure {Shape : Type} {Pos : Shape -> Type} {A B : Type} + `{Normalform Shape Pos A B} + : forall s (pf : _ -> Free Shape Pos A), + nf (impure s pf) = impure s (fun p => nf (pf p)). +Proof. trivial. Qed. + +Lemma nfPure {Shape : Type} {Pos : Shape -> Type} {A B : Type} + `{Normalform Shape Pos A B} : forall (x : A), + nf (pure x) = nf' x. +Proof. trivial. Qed. + + diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 60247fc4..c0e8f55e 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -4,7 +4,7 @@ module FreeC.Backend.Coq.Converter.TypeDecl where import Control.Monad ( mapAndUnzipM, foldM, replicateM ) import Control.Monad.Extra ( concatMapM ) -import Data.List ( partition, nub, intercalate ) -- TODO: Remove intercalate +import Data.List ( partition, nub ) import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe ( catMaybes, fromJust ) import qualified Data.Map as Map @@ -209,56 +209,62 @@ generateInstances dataDecls = do return nfInstances where declTypes = map dataDeclToType dataDecls + conNames = map IR.typeDeclQName dataDecls - generateNormalformInstances :: Converter [Coq.Sentence] - generateNormalformInstances = do + generateNormalformInstances :: Converter [ Coq.Sentence ] + generateNormalformInstances = do topLevelMap <- nameFunctionsAndInsert "nf'" emptyTypeMap declTypes - topLevelVars <- map Coq.bare <$> mapM freshCoqIdent + topLevelVars <- map Coq.bare <$> mapM freshCoqIdent (replicate (length declTypes) "x") nf' <- generateNf' topLevelMap dataDecls declTypes topLevelVars instances <- mapM (buildInstance topLevelMap) declTypes return (nf' : instances) - + buildInstance :: TypeMap -> IR.Type -> Converter Coq.Sentence - buildInstance m t = do - -- nf' := nf'T - let instanceBody = (Coq.bare "nf'", Coq.Qualid (fromJust (lookupType t m))) + buildInstance m t = localEnv $ do + -- @nf' := nf'T@ + let instanceBody + = ( Coq.bare "nf'", Coq.Qualid (fromJust (lookupType t m)) ) -- Get the binders and return type for the instance declaration - (binders,retType) <- makeNFInstanceBindersAndReturnType t + ( binders, retType ) <- makeNFInstanceBindersAndReturnType t instanceName <- Coq.bare <$> nameFunction "Normalform" t - return $ Coq.InstanceSentence (Coq.InstanceDefinition instanceName binders retType [instanceBody] Nothing) - - generateNf' :: TypeMap -> [ IR.TypeDecl ] -> [ IR.Type ] -> [Coq.Qualid] -> Converter Coq.Sentence - generateNf' topLevelMap dataDecls declTypes topLevelVars = do - - - -- rhss <- mapM (generateBody topLevelMap) - -- (zip3 topLevelVars dataDecls declTypes) - fixBodies <- mapM (uncurry (uncurry (makeFixBody topLevelMap))) (zip (zip topLevelVars declTypes) dataDecls) + return $ Coq.InstanceSentence (Coq.InstanceDefinition instanceName + binders retType [ instanceBody ] Nothing) + + generateNf' :: TypeMap -> [ IR.TypeDecl ] + -> [ IR.Type ] -> [ Coq.Qualid ] -> Converter Coq.Sentence + generateNf' topLevelMap dataDecls declTypes topLevelVars = localEnv $ do + fixBodies <- mapM (uncurry (uncurry (makeFixBody topLevelMap))) + (zip (zip topLevelVars declTypes) dataDecls) return $ Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) where - - - makeFixBody :: TypeMap -> Coq.Qualid -> IR.Type -> IR.TypeDecl -> Converter Coq.FixBody + makeFixBody :: TypeMap + -> Coq.Qualid -> IR.Type -> IR.TypeDecl -> Converter Coq.FixBody makeFixBody m var t decl = do rhs <- generateBody m var decl t - (binders,retType) <- makeNFBindersAndReturnType' t var - return $ Coq.FixBody (fromJust (lookupType t m)) (NonEmpty.fromList binders ) Nothing (Just retType) rhs - + ( binders, retType ) <- makeNFBindersAndReturnType' t var + return $ Coq.FixBody (fromJust (lookupType t m)) + (NonEmpty.fromList binders) Nothing (Just retType) rhs - generateBody :: TypeMap -> Coq.Qualid -> IR.TypeDecl -> IR.Type -> Converter Coq.Term -- TODO: don't do that. Sort these functions properly. - generateBody topLevelMap ident tDecl t = do + generateBody + :: TypeMap -> Coq.Qualid -> IR.TypeDecl -> IR.Type -> Converter + Coq.Term -- TODO: don't do that. Sort these functions properly. + + generateBody topLevelMap ident tDecl t = do let ts = nub (reverse (concatMap (collectSubTypes conNames) (concatMap IR.conDeclFields (IR.dataDeclCons tDecl)))) let recTypes = filter (\t -> not (t `elem` declTypes || isTypeVar t)) ts - let typeVars = map (Coq.bare . IR.typeVarDeclIdent) (IR.typeDeclArgs tDecl) - targetVars <- (map Coq.bare) <$> replicateM (length typeVars) (freshCoqIdent "b") + let typeVars = map (Coq.bare . IR.typeVarDeclIdent) + (IR.typeDeclArgs tDecl) + targetVars <- (map Coq.bare) <$> replicateM (length typeVars) + (freshCoqIdent "b") let freeQualids = map fst Coq.Base.freeArgs - normalformFuncMap <- nameFunctionsAndInsert "nf'" topLevelMap recTypes + normalformFuncMap + <- nameFunctionsAndInsert "nf'" topLevelMap recTypes nf'Body <- generateNf'Body normalformFuncMap ident t recTypes return nf'Body @@ -270,11 +276,12 @@ generateInstances dataDecls = do inBody <- generateNf'Body m ident t recTypes var <- Coq.bare <$> freshCoqIdent "x" letBody <- matchConstructors m var recType - (binders,retType) <- makeNFBindersAndReturnType' recType var + ( binders, retType ) <- makeNFBindersAndReturnType' recType var let Just localFuncName = lookupType recType m return $ Coq.Let localFuncName [] Nothing - (Coq.Fix (Coq.FixOne (Coq.FixBody localFuncName (NonEmpty.fromList binders) Nothing - (Just retType) letBody))) inBody + (Coq.Fix (Coq.FixOne + (Coq.FixBody localFuncName (NonEmpty.fromList binders) + Nothing (Just retType) letBody))) inBody matchConstructors :: TypeMap -> Coq.Qualid -> IR.Type -> Converter Coq.Term @@ -340,7 +347,7 @@ showPrettyType (IR.TypeApp _ l r) = do rPretty <- showPrettyType r return (lPretty ++ rPretty) -collectSubTypes :: [IR.ConName] -> IR.Type -> [IR.Type] +collectSubTypes :: [ IR.ConName ] -> IR.Type -> [ IR.Type ] collectSubTypes = collectFullyAppliedTypes True collectFullyAppliedTypes :: Bool -> [ IR.ConName ] -> IR.Type -> [ IR.Type ] @@ -364,7 +371,8 @@ stripType' (IR.TypeApp _ l r) names flag = case stripType' r names False of r' -> IR.TypeApp NoSrcSpan (stripType' l names True) r' nameFunctionsAndInsert :: String -> TypeMap -> [ IR.Type ] -> Converter TypeMap -nameFunctionsAndInsert prefix m ts = localEnv $ foldM (nameFunctionAndInsert prefix) m ts +nameFunctionsAndInsert prefix m ts = localEnv $ foldM + (nameFunctionAndInsert prefix) m ts nameFunctionAndInsert :: String -> TypeMap -> IR.Type -> Converter TypeMap nameFunctionAndInsert prefix m t = do @@ -377,7 +385,6 @@ nameFunction :: String -> IR.Type -> Converter String nameFunction prefix t = do prettyType <- showPrettyType t freshCoqIdent (prefix ++ prettyType) - dataDeclToType :: IR.TypeDecl -> IR.Type dataDeclToType dataDecl = IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) @@ -393,15 +400,17 @@ getTypeConName (IR.TypeCon _ conName) = Just conName getTypeConName (IR.TypeApp _ l r) = getTypeConName l getTypeConName _ = Nothing -buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder -buildConstraint ident args = Coq.Generalized Coq.Implicit (Coq.app (Coq.Qualid (Coq.bare ident)) ((map (Coq.Qualid . fst) Coq.Base.freeArgs) ++ (map Coq.Qualid args))) - +buildConstraint :: String -> [ Coq.Qualid ] -> Coq.Binder +buildConstraint ident args = Coq.Generalized Coq.Implicit + (Coq.app (Coq.Qualid (Coq.bare ident)) + ((map (Coq.Qualid . fst) Coq.Base.freeArgs) ++ (map Coq.Qualid args))) -- Coq AST helper functions -freeArgsBinders :: [Coq.Binder] -freeArgsBinders = map (uncurry (Coq.typedBinder' Coq.Implicit)) Coq.Base.freeArgs +freeArgsBinders :: [ Coq.Binder ] +freeArgsBinders = map (uncurry (Coq.typedBinder' Coq.Implicit)) + Coq.Base.freeArgs -typeBinder :: [Coq.Qualid] -> Coq.Binder +typeBinder :: [ Coq.Qualid ] -> Coq.Binder typeBinder typeVars = Coq.typedBinder Coq.Implicit typeVars Coq.sortType -- TODO: Does this exist somewhere? @@ -413,50 +422,59 @@ applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [ mx, f ] -- Given an A, returns Free Shape Pos A applyFree :: Coq.Term -> Coq.Term -applyFree a = Coq.app (Coq.Qualid Coq.Base.free) ((map (Coq.Qualid . fst) Coq.Base.freeArgs) ++ [a]) +applyFree a = Coq.app (Coq.Qualid Coq.Base.free) + ((map (Coq.Qualid . fst) Coq.Base.freeArgs) ++ [ a ]) + +shapeAndPos :: [ Coq.Term ] +shapeAndPos = map (Coq.Qualid . fst) Coq.Base.freeArgs + +idShapeAndPos :: [ Coq.Term ] +idShapeAndPos + = (map (Coq.Qualid . Coq.bare) [ "Identity.Shape", "Identity.Pos" ]) -- converts our type into a Coq type (a term) with new variables for all don't care values -toCoqType :: String -> [Coq.Term] -> IR.Type -> Converter (Coq.Term, [Coq.Qualid]) +toCoqType :: String + -> [ Coq.Term ] -> IR.Type -> Converter ( Coq.Term, [ Coq.Qualid ] ) toCoqType varPrefix _ (IR.TypeVar _ _) = do x <- Coq.bare <$> freshCoqIdent varPrefix - return (Coq.Qualid x, [x]) + return ( Coq.Qualid x, [ x ] ) toCoqType varPrefix shapeAndPos (IR.TypeCon _ conName) = do entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName - return (Coq.app (Coq.Qualid (entryIdent entry)) shapeAndPos, [] ) + return ( Coq.app (Coq.Qualid (entryIdent entry)) shapeAndPos, [] ) toCoqType varPrefix shapeAndPos (IR.TypeApp _ l r) = do - (l',varsl) <- toCoqType varPrefix shapeAndPos l - (r',varsr) <- toCoqType varPrefix shapeAndPos r - return (Coq.app l' [r'], varsl ++ varsr) + ( l', varsl ) <- toCoqType varPrefix shapeAndPos l + ( r', varsr ) <- toCoqType varPrefix shapeAndPos r + return ( Coq.app l' [ r' ], varsl ++ varsr ) -makeNFBindersAndReturnType' :: IR.Type -> Coq.Qualid -> Converter ([Coq.Binder],Coq.Term) +makeNFBindersAndReturnType' + :: IR.Type -> Coq.Qualid -> Converter ( [ Coq.Binder ], Coq.Term ) makeNFBindersAndReturnType' t varName = do - (binders,sourceType,targetType) <- makeNFBindersAndReturnType t - let binders' = binders ++ [(Coq.typedBinder' Coq.Explicit varName sourceType)] + ( binders, sourceType, targetType ) <- makeNFBindersAndReturnType t + let binders' = binders + ++ [ (Coq.typedBinder' Coq.Explicit varName sourceType) ] let retType = applyFree targetType - return (binders',retType) + return ( binders', retType ) -shapeAndPos :: [Coq.Term] -shapeAndPos = map (Coq.Qualid . fst) Coq.Base.freeArgs -idShapeAndPos :: [Coq.Term] -idShapeAndPos = (map (Coq.Qualid . Coq.bare) ["Identity.Shape", "Identity.Pos"]) - -makeNFInstanceBindersAndReturnType :: IR.Type -> Converter ([Coq.Binder], Coq.Term) +makeNFInstanceBindersAndReturnType + :: IR.Type -> Converter ( [ Coq.Binder ], Coq.Term ) makeNFInstanceBindersAndReturnType t = do - (binders,sourceType,targetType) <- makeNFBindersAndReturnType t - let retType = Coq.app (Coq.Qualid (Coq.bare "Normalform")) (shapeAndPos ++ [sourceType,targetType]) - return (binders,retType) - - + ( binders, sourceType, targetType ) <- makeNFBindersAndReturnType t + let retType = Coq.app (Coq.Qualid (Coq.bare "Normalform")) + (shapeAndPos ++ [ sourceType, targetType ]) + return ( binders, retType ) + -- makes appropriate binders and return type for a (possibly local) nf' function -makeNFBindersAndReturnType :: IR.Type -> Converter ([Coq.Binder],Coq.Term,Coq.Term) +makeNFBindersAndReturnType + :: IR.Type -> Converter ( [ Coq.Binder ], Coq.Term, Coq.Term ) makeNFBindersAndReturnType t = do - (sourceType,sourceVars) <- toCoqType "a" shapeAndPos t - (targetType,targetVars) <- toCoqType "b" idShapeAndPos t - let constraints = map (buildConstraint "Normalform") (zipWith (\v1 v2 -> [v1] ++ [v2]) sourceVars targetVars) - let binders = freeArgsBinders ++ [typeBinder (sourceVars ++ targetVars)] ++ constraints - return (binders,sourceType,targetType) - - + ( sourceType, sourceVars ) <- toCoqType "a" shapeAndPos t + ( targetType, targetVars ) <- toCoqType "b" idShapeAndPos t + let constraints = map (buildConstraint "Normalform") + (zipWith (\v1 v2 -> [ v1 ] ++ [ v2 ]) sourceVars targetVars) + let binders = freeArgsBinders ++ [ typeBinder (sourceVars ++ targetVars) ] + ++ constraints + return ( binders, sourceType, targetType ) + type TypeMap = IR.Type -> Maybe Coq.Qualid emptyTypeMap :: TypeMap From 65d4222bdde7a9fab6e953ae3000e816cbc89eda Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Wed, 26 Aug 2020 20:22:28 +0200 Subject: [PATCH 005/120] Format code #150 --- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 695 +++++++++--------- 1 file changed, 355 insertions(+), 340 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index c0e8f55e..d455bea9 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -2,51 +2,54 @@ -- declarations and their constructors. module FreeC.Backend.Coq.Converter.TypeDecl where -import Control.Monad ( mapAndUnzipM, foldM, replicateM ) -import Control.Monad.Extra ( concatMapM ) -import Data.List ( partition, nub ) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe ( catMaybes, fromJust ) -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified FreeC.Backend.Coq.Syntax as Coq -import FreeC.Backend.Coq.Converter.Arg -import FreeC.Backend.Coq.Converter.Free -import FreeC.Backend.Coq.Converter.Type -import qualified FreeC.Backend.Coq.Base as Coq.Base -import FreeC.Environment -import FreeC.Environment.Entry -import FreeC.Environment.LookupOrFail -import FreeC.Environment.Fresh -import FreeC.IR.DependencyGraph -import FreeC.IR.Subst -import qualified FreeC.IR.Syntax as IR -import FreeC.IR.TypeSynExpansion -import FreeC.IR.Unification -import FreeC.Monad.Converter -import FreeC.Monad.Reporter -import FreeC.Pretty -import FreeC.IR.SrcSpan ( SrcSpan(NoSrcSpan) ) +import Control.Monad + ( foldM, mapAndUnzipM, replicateM ) +import Control.Monad.Extra ( concatMapM ) +import Data.List ( nub, partition ) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map +import Data.Maybe ( catMaybes, fromJust ) +import qualified Data.Set as Set + +import qualified FreeC.Backend.Coq.Base as Coq.Base +import FreeC.Backend.Coq.Converter.Arg +import FreeC.Backend.Coq.Converter.Free +import FreeC.Backend.Coq.Converter.Type +import qualified FreeC.Backend.Coq.Syntax as Coq +import FreeC.Environment +import FreeC.Environment.Entry +import FreeC.Environment.Fresh +import FreeC.Environment.LookupOrFail +import FreeC.IR.DependencyGraph +import FreeC.IR.SrcSpan ( SrcSpan(NoSrcSpan) ) +import FreeC.IR.Subst +import qualified FreeC.IR.Syntax as IR +import FreeC.IR.TypeSynExpansion +import FreeC.IR.Unification +import FreeC.Monad.Converter +import FreeC.Monad.Reporter +import FreeC.Pretty ------------------------------------------------------------------------------- -- Strongly connected components -- ------------------------------------------------------------------------------- -- | Converts a strongly connected component of the type dependency graph. convertTypeComponent - :: DependencyComponent IR.TypeDecl -> Converter [ Coq.Sentence ] + :: DependencyComponent IR.TypeDecl -> Converter [Coq.Sentence] convertTypeComponent (NonRecursive decl) - | isTypeSynDecl decl = convertTypeSynDecl decl - | otherwise = convertDataDecls [ decl ] -convertTypeComponent (Recursive decls) = do - let ( typeSynDecls, dataDecls ) = partition isTypeSynDecl decls - typeSynDeclQNames = Set.fromList (map IR.typeDeclQName typeSynDecls) - sortedTypeSynDecls <- sortTypeSynDecls typeSynDecls - expandedDataDecls <- mapM - (expandAllTypeSynonymsInDeclWhere (`Set.member` typeSynDeclQNames)) - dataDecls - dataDecls' <- convertDataDecls expandedDataDecls - typeSynDecls' <- concatMapM convertTypeSynDecl sortedTypeSynDecls - return (dataDecls' ++ typeSynDecls') + | isTypeSynDecl decl = convertTypeSynDecl decl + | otherwise = convertDataDecls [decl] +convertTypeComponent (Recursive decls) = do + let (typeSynDecls, dataDecls) = partition isTypeSynDecl decls + typeSynDeclQNames = Set.fromList + (map IR.typeDeclQName typeSynDecls) + sortedTypeSynDecls <- sortTypeSynDecls typeSynDecls + expandedDataDecls <- mapM + (expandAllTypeSynonymsInDeclWhere (`Set.member` typeSynDeclQNames)) + dataDecls + dataDecls' <- convertDataDecls expandedDataDecls + typeSynDecls' <- concatMapM convertTypeSynDecl sortedTypeSynDecls + return (dataDecls' ++ typeSynDecls') -- | Sorts type synonym declarations topologically. -- @@ -55,7 +58,7 @@ convertTypeComponent (Recursive decls) = do -- if they form a cycle). However, type synonyms may still depend on other -- type synonyms from the same strongly connected component. Therefore we -- have to sort the declarations in reverse topological order. -sortTypeSynDecls :: [ IR.TypeDecl ] -> Converter [ IR.TypeDecl ] +sortTypeSynDecls :: [IR.TypeDecl] -> Converter [IR.TypeDecl] sortTypeSynDecls = mapM fromNonRecursive . groupTypeDecls -- | Extracts the single type synonym declaration from a strongly connected @@ -65,10 +68,10 @@ sortTypeSynDecls = mapM fromNonRecursive . groupTypeDecls -- declarations (i.e. type synonyms form a cycle). fromNonRecursive :: DependencyComponent IR.TypeDecl -> Converter IR.TypeDecl fromNonRecursive (NonRecursive decl) = return decl -fromNonRecursive (Recursive decls) = reportFatal $ Message - (IR.typeDeclSrcSpan (head decls)) Error - $ "Type synonym declarations form a cycle: " ++ showPretty - (map IR.typeDeclIdent decls) +fromNonRecursive (Recursive decls) = reportFatal + $ Message (IR.typeDeclSrcSpan (head decls)) Error + $ "Type synonym declarations form a cycle: " + ++ showPretty (map IR.typeDeclIdent decls) ------------------------------------------------------------------------------- -- Type synonym declarations -- @@ -76,23 +79,23 @@ fromNonRecursive (Recursive decls) = reportFatal $ Message -- | Tests whether the given declaration is a type synonym declaration. isTypeSynDecl :: IR.TypeDecl -> Bool isTypeSynDecl (IR.TypeSynDecl _ _ _ _) = True -isTypeSynDecl (IR.DataDecl _ _ _ _) = False +isTypeSynDecl (IR.DataDecl _ _ _ _) = False -- | Converts a Haskell type synonym declaration to Coq. -convertTypeSynDecl :: IR.TypeDecl -> Converter [ Coq.Sentence ] +convertTypeSynDecl :: IR.TypeDecl -> Converter [Coq.Sentence] convertTypeSynDecl decl@(IR.TypeSynDecl _ _ typeVarDecls typeExpr) - = localEnv $ do - let name = IR.typeDeclQName decl - Just qualid <- inEnv $ lookupIdent IR.TypeScope name - typeVarDecls' <- convertTypeVarDecls Coq.Explicit typeVarDecls - typeExpr' <- convertType' typeExpr - return [ Coq.definitionSentence qualid - (genericArgDecls Coq.Explicit ++ typeVarDecls') - (Just Coq.sortType) typeExpr' - ] + = localEnv $ do + let name = IR.typeDeclQName decl + Just qualid <- inEnv $ lookupIdent IR.TypeScope name + typeVarDecls' <- convertTypeVarDecls Coq.Explicit typeVarDecls + typeExpr' <- convertType' typeExpr + return [ Coq.definitionSentence qualid + (genericArgDecls Coq.Explicit ++ typeVarDecls') + (Just Coq.sortType) typeExpr' + ] -- Data type declarations are not allowed in this function. convertTypeSynDecl (IR.DataDecl _ _ _ _) - = error "convertTypeSynDecl: Data type declaration not allowed." + = error "convertTypeSynDecl: Data type declaration not allowed." ------------------------------------------------------------------------------- -- Data type declarations -- @@ -110,15 +113,15 @@ convertTypeSynDecl (IR.DataDecl _ _ _ _) -- After the @Inductive@ sentences for the data type declarations there -- is one @Arguments@ sentence and one smart constructor declaration for -- each constructor declaration of the given data types. -convertDataDecls :: [ IR.TypeDecl ] -> Converter [ Coq.Sentence ] +convertDataDecls :: [IR.TypeDecl] -> Converter [Coq.Sentence] convertDataDecls dataDecls = do - ( indBodies, extraSentences ) <- mapAndUnzipM convertDataDecl dataDecls - instances <- generateInstances dataDecls - return - (Coq.comment ("Data type declarations for " ++ showPretty - (map IR.typeDeclName dataDecls)) : Coq.InductiveSentence - (Coq.Inductive (NonEmpty.fromList indBodies) []) - : concat extraSentences ++ instances) + (indBodies, extraSentences) <- mapAndUnzipM convertDataDecl dataDecls + instances <- generateInstances dataDecls + return + (Coq.comment ("Data type declarations for " + ++ showPretty (map IR.typeDeclName dataDecls)) + : Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList indBodies) []) + : concat extraSentences ++ instances) -- | Converts a Haskell data type declaration to the body of a Coq @Inductive@ -- sentence, the @Arguments@ sentences for it's constructors and the smart @@ -126,273 +129,285 @@ convertDataDecls dataDecls = do -- -- Type variables declared by the data type or the smart constructors are -- not visible outside of this function. -convertDataDecl :: IR.TypeDecl -> Converter ( Coq.IndBody, [ Coq.Sentence ] ) +convertDataDecl :: IR.TypeDecl -> Converter (Coq.IndBody, [Coq.Sentence]) convertDataDecl (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do - ( body, argumentsSentences ) <- generateBodyAndArguments - smartConDecls <- mapM generateSmartConDecl conDecls - return ( body - , Coq.comment ("Arguments sentences for " ++ showPretty - (IR.toUnQual name)) : argumentsSentences - ++ Coq.comment ("Smart constructors for " ++ showPretty - (IR.toUnQual name)) : smartConDecls + (body, argumentsSentences) <- generateBodyAndArguments + smartConDecls <- mapM generateSmartConDecl conDecls + return + ( body + , Coq.comment ("Arguments sentences for " ++ showPretty (IR.toUnQual name)) + : argumentsSentences + ++ Coq.comment + ("Smart constructors for " ++ showPretty (IR.toUnQual name)) + : smartConDecls + ) + where + -- | Generates the body of the @Inductive@ sentence and the @Arguments@ + -- sentences for the constructors but not the smart constructors + -- of the data type. + -- + -- Type variables declared by the data type declaration are visible to the + -- constructor declarations and @Arguments@ sentences created by this + -- function, but not outside this function. This allows the smart + -- constructors to reuse the identifiers for their type arguments (see + -- 'generateSmartConDecl'). + generateBodyAndArguments :: Converter (Coq.IndBody, [Coq.Sentence]) + generateBodyAndArguments = localEnv $ do + Just qualid <- inEnv $ lookupIdent IR.TypeScope name + typeVarDecls' <- convertTypeVarDecls Coq.Explicit typeVarDecls + conDecls' <- mapM convertConDecl conDecls + argumentsSentences <- mapM generateArgumentsSentence conDecls + return ( Coq.IndBody qualid (genericArgDecls Coq.Explicit ++ typeVarDecls') + Coq.sortType conDecls' + , argumentsSentences ) - where - -- | Generates the body of the @Inductive@ sentence and the @Arguments@ - -- sentences for the constructors but not the smart constructors - -- of the data type. - -- - -- Type variables declared by the data type declaration are visible to the - -- constructor declarations and @Arguments@ sentences created by this - -- function, but not outside this function. This allows the smart - -- constructors to reuse the identifiers for their type arguments (see - -- 'generateSmartConDecl'). - generateBodyAndArguments :: Converter ( Coq.IndBody, [ Coq.Sentence ] ) - generateBodyAndArguments = localEnv $ do - Just qualid <- inEnv $ lookupIdent IR.TypeScope name - typeVarDecls' <- convertTypeVarDecls Coq.Explicit typeVarDecls - conDecls' <- mapM convertConDecl conDecls - argumentsSentences <- mapM generateArgumentsSentence conDecls - return - ( Coq.IndBody qualid (genericArgDecls Coq.Explicit ++ typeVarDecls') - Coq.sortType conDecls' - , argumentsSentences - ) - - -- | Converts a constructor of the data type. - convertConDecl :: IR.ConDecl - -> Converter ( Coq.Qualid, [ Coq.Binder ], Maybe Coq.Term ) - convertConDecl (IR.ConDecl _ (IR.DeclIdent _ conName) args) = do - Just conQualid <- inEnv $ lookupIdent IR.ValueScope conName - Just returnType <- inEnv $ lookupReturnType IR.ValueScope conName - args' <- mapM convertType args - returnType' <- convertType' returnType - return ( conQualid, [], Just (args' `Coq.arrows` returnType') ) - - -- | Generates the @Arguments@ sentence for the given constructor declaration. - generateArgumentsSentence :: IR.ConDecl -> Converter Coq.Sentence - generateArgumentsSentence (IR.ConDecl _ (IR.DeclIdent _ conName) _) = do - Just qualid <- inEnv $ lookupIdent IR.ValueScope conName - let typeVarNames = map IR.typeVarDeclQName typeVarDecls - typeVarQualids <- mapM (inEnv . lookupIdent IR.TypeScope) typeVarNames - return (Coq.ArgumentsSentence - (Coq.Arguments Nothing qualid - [ Coq.ArgumentSpec Coq.ArgMaximal (Coq.Ident typeVarQualid) - Nothing | typeVarQualid - <- map fst Coq.Base.freeArgs ++ catMaybes typeVarQualids - ])) - - -- | Generates the smart constructor declaration for the given constructor - -- declaration. - generateSmartConDecl :: IR.ConDecl -> Converter Coq.Sentence - generateSmartConDecl (IR.ConDecl _ declIdent argTypes) = localEnv $ do - let conName = IR.declIdentName declIdent - Just qualid <- inEnv $ lookupIdent IR.ValueScope conName - Just smartQualid <- inEnv $ lookupSmartIdent conName - Just returnType <- inEnv $ lookupReturnType IR.ValueScope conName - typeVarDecls' <- convertTypeVarDecls Coq.Implicit typeVarDecls - ( argIdents', argDecls' ) <- mapAndUnzipM convertAnonymousArg - (map Just argTypes) - returnType' <- convertType returnType - rhs <- generatePure - (Coq.app (Coq.Qualid qualid) (map Coq.Qualid argIdents')) - return (Coq.definitionSentence smartQualid - (genericArgDecls Coq.Explicit ++ typeVarDecls' ++ argDecls') - (Just returnType') rhs) + + -- | Converts a constructor of the data type. + convertConDecl + :: IR.ConDecl -> Converter (Coq.Qualid, [Coq.Binder], Maybe Coq.Term) + convertConDecl (IR.ConDecl _ (IR.DeclIdent _ conName) args) = do + Just conQualid <- inEnv $ lookupIdent IR.ValueScope conName + Just returnType <- inEnv $ lookupReturnType IR.ValueScope conName + args' <- mapM convertType args + returnType' <- convertType' returnType + return (conQualid, [], Just (args' `Coq.arrows` returnType')) + + -- | Generates the @Arguments@ sentence for the given constructor declaration. + generateArgumentsSentence :: IR.ConDecl -> Converter Coq.Sentence + generateArgumentsSentence (IR.ConDecl _ (IR.DeclIdent _ conName) _) = do + Just qualid <- inEnv $ lookupIdent IR.ValueScope conName + let typeVarNames = map IR.typeVarDeclQName typeVarDecls + typeVarQualids <- mapM (inEnv . lookupIdent IR.TypeScope) typeVarNames + return (Coq.ArgumentsSentence + (Coq.Arguments Nothing qualid + [Coq.ArgumentSpec Coq.ArgMaximal (Coq.Ident typeVarQualid) Nothing + | typeVarQualid + <- map fst Coq.Base.freeArgs ++ catMaybes typeVarQualids + ])) + + -- | Generates the smart constructor declaration for the given constructor + -- declaration. + generateSmartConDecl :: IR.ConDecl -> Converter Coq.Sentence + generateSmartConDecl (IR.ConDecl _ declIdent argTypes) = localEnv $ do + let conName = IR.declIdentName declIdent + Just qualid <- inEnv $ lookupIdent IR.ValueScope conName + Just smartQualid <- inEnv $ lookupSmartIdent conName + Just returnType <- inEnv $ lookupReturnType IR.ValueScope conName + typeVarDecls' <- convertTypeVarDecls Coq.Implicit typeVarDecls + (argIdents', argDecls') <- mapAndUnzipM convertAnonymousArg + (map Just argTypes) + returnType' <- convertType returnType + rhs <- generatePure + (Coq.app (Coq.Qualid qualid) (map Coq.Qualid argIdents')) + return (Coq.definitionSentence smartQualid + (genericArgDecls Coq.Explicit ++ typeVarDecls' ++ argDecls') + (Just returnType') rhs) -- Type synonyms are not allowed in this function. convertDataDecl (IR.TypeSynDecl _ _ _ _) - = error "convertDataDecl: Type synonym not allowed." + = error "convertDataDecl: Type synonym not allowed." ------ Instance generation ------- -generateInstances :: [ IR.TypeDecl ] -> Converter [ Coq.Sentence ] +generateInstances :: [IR.TypeDecl] -> Converter [Coq.Sentence] generateInstances dataDecls = do - nfInstances <- generateNormalformInstances - return nfInstances - where - declTypes = map dataDeclToType dataDecls - - conNames = map IR.typeDeclQName dataDecls - - generateNormalformInstances :: Converter [ Coq.Sentence ] - generateNormalformInstances = do - topLevelMap <- nameFunctionsAndInsert "nf'" emptyTypeMap declTypes - topLevelVars <- map Coq.bare <$> mapM freshCoqIdent - (replicate (length declTypes) "x") - nf' <- generateNf' topLevelMap dataDecls declTypes topLevelVars - instances <- mapM (buildInstance topLevelMap) declTypes - return (nf' : instances) - - buildInstance :: TypeMap -> IR.Type -> Converter Coq.Sentence - buildInstance m t = localEnv $ do - -- @nf' := nf'T@ - let instanceBody - = ( Coq.bare "nf'", Coq.Qualid (fromJust (lookupType t m)) ) - -- Get the binders and return type for the instance declaration - ( binders, retType ) <- makeNFInstanceBindersAndReturnType t - instanceName <- Coq.bare <$> nameFunction "Normalform" t - return $ Coq.InstanceSentence (Coq.InstanceDefinition instanceName - binders retType [ instanceBody ] Nothing) - - generateNf' :: TypeMap -> [ IR.TypeDecl ] - -> [ IR.Type ] -> [ Coq.Qualid ] -> Converter Coq.Sentence - generateNf' topLevelMap dataDecls declTypes topLevelVars = localEnv $ do - fixBodies <- mapM (uncurry (uncurry (makeFixBody topLevelMap))) - (zip (zip topLevelVars declTypes) dataDecls) - return $ Coq.FixpointSentence - (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) - where - makeFixBody :: TypeMap - -> Coq.Qualid -> IR.Type -> IR.TypeDecl -> Converter Coq.FixBody - makeFixBody m var t decl = do - rhs <- generateBody m var decl t - ( binders, retType ) <- makeNFBindersAndReturnType' t var - return $ Coq.FixBody (fromJust (lookupType t m)) - (NonEmpty.fromList binders) Nothing (Just retType) rhs - - generateBody - :: TypeMap -> Coq.Qualid -> IR.TypeDecl -> IR.Type -> Converter - Coq.Term -- TODO: don't do that. Sort these functions properly. - - generateBody topLevelMap ident tDecl t = do - let ts = nub (reverse (concatMap (collectSubTypes conNames) - (concatMap IR.conDeclFields - (IR.dataDeclCons tDecl)))) - let recTypes = filter - (\t -> not (t `elem` declTypes || isTypeVar t)) ts - let typeVars = map (Coq.bare . IR.typeVarDeclIdent) - (IR.typeDeclArgs tDecl) - targetVars <- (map Coq.bare) <$> replicateM (length typeVars) - (freshCoqIdent "b") - let freeQualids = map fst Coq.Base.freeArgs - normalformFuncMap - <- nameFunctionsAndInsert "nf'" topLevelMap recTypes - nf'Body <- generateNf'Body normalformFuncMap ident t recTypes - return nf'Body - - -- letfix distinction - generateNf'Body :: TypeMap - -> Coq.Qualid -> IR.Type -> [ IR.Type ] -> Converter Coq.Term - generateNf'Body m ident t [] = matchConstructors m ident t - generateNf'Body m ident t (recType : recTypes) = do - inBody <- generateNf'Body m ident t recTypes - var <- Coq.bare <$> freshCoqIdent "x" - letBody <- matchConstructors m var recType - ( binders, retType ) <- makeNFBindersAndReturnType' recType var - let Just localFuncName = lookupType recType m - return $ Coq.Let localFuncName [] Nothing - (Coq.Fix (Coq.FixOne - (Coq.FixBody localFuncName (NonEmpty.fromList binders) - Nothing (Just retType) letBody))) inBody - - matchConstructors - :: TypeMap -> Coq.Qualid -> IR.Type -> Converter Coq.Term - matchConstructors m ident t = do - let Just conName = getTypeConName t - entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName - equations <- mapM (buildEquation m t) (entryConsNames entry) - return $ Coq.match (Coq.Qualid ident) equations - - -- type: type expression for unification - -- consName : data constructor name of type - buildEquation :: TypeMap -> IR.Type -> IR.ConName -> Converter - Coq.Equation -- TODO: rename type args before unification - - buildEquation m t conName = do - conEntry <- lookupEntryOrFail NoSrcSpan IR.ValueScope conName - let retType = entryReturnType conEntry - let conIdent = entryIdent conEntry -- :: Qualid - conArgIdents <- (map Coq.bare) <$> replicateM (entryArity conEntry) - (freshCoqIdent "fx") - subst <- unifyOrFail NoSrcSpan t retType - let modArgTypes = map ((stripType conNames) . (applySubst subst)) - (entryArgTypes conEntry) - let lhs = Coq.ArgsPat conIdent (map Coq.QualidPat conArgIdents) - rhs <- buildNormalformValue m conIdent [] - (zip modArgTypes conArgIdents) - return $ Coq.equation lhs rhs - - -- TODO: Split into normal function and helper function because of the accumulator. - buildNormalformValue :: TypeMap -> Coq.Qualid -> [ Coq.Qualid ] - -> [ ( IR.Type, Coq.Qualid ) ] -> Converter Coq.Term - buildNormalformValue nameMap consName vals [] = return $ applyPure - (Coq.app (Coq.Qualid consName) - (map (applyPure . Coq.Qualid) (reverse vals))) - buildNormalformValue nameMap consName vals (( t, varName ) : consVars) - = case lookupType t nameMap of - Just funcName -> do - x <- Coq.bare <$> freshCoqIdent "x" - nx <- Coq.bare <$> freshCoqIdent "nx" - rhs <- buildNormalformValue nameMap consName (nx : vals) - consVars - let c = Coq.fun [ nx ] [ Nothing ] rhs - let c'' = applyBind (Coq.app (Coq.Qualid funcName) - [ (Coq.Qualid x) ]) c - return $ applyBind (Coq.Qualid varName) - (Coq.fun [ x ] [ Nothing ] c'') - Nothing -> do - nx <- Coq.bare <$> freshCoqIdent "nx" - rhs <- buildNormalformValue nameMap consName (nx : vals) - consVars - let cont = Coq.fun [ nx ] [ Nothing ] rhs - return $ applyBind (Coq.app (Coq.Qualid (Coq.bare "nf")) - [ (Coq.Qualid varName) ]) cont + nfInstances <- generateNormalformInstances + return nfInstances + where + declTypes = map dataDeclToType dataDecls + + conNames = map IR.typeDeclQName dataDecls + + generateNormalformInstances :: Converter [Coq.Sentence] + generateNormalformInstances = do + topLevelMap <- nameFunctionsAndInsert "nf'" emptyTypeMap declTypes + topLevelVars <- map Coq.bare + <$> mapM freshCoqIdent (replicate (length declTypes) "x") + nf' <- generateNf' topLevelMap dataDecls declTypes topLevelVars + instances <- mapM (buildInstance topLevelMap) declTypes + return (nf' : instances) + + buildInstance :: TypeMap -> IR.Type -> Converter Coq.Sentence + buildInstance m t = localEnv $ do + -- @nf' := nf'T@ + let instanceBody = (Coq.bare "nf'", Coq.Qualid (fromJust (lookupType t m))) + -- Get the binders and return type for the instance declaration + (binders, retType) <- makeNFInstanceBindersAndReturnType t + instanceName <- Coq.bare <$> nameFunction "Normalform" t + return + $ Coq.InstanceSentence (Coq.InstanceDefinition instanceName binders + retType [instanceBody] Nothing) + + generateNf' :: TypeMap + -> [IR.TypeDecl] + -> [IR.Type] + -> [Coq.Qualid] + -> Converter Coq.Sentence + generateNf' topLevelMap dataDecls declTypes topLevelVars = localEnv $ do + fixBodies <- mapM (uncurry (uncurry (makeFixBody topLevelMap))) + (zip (zip topLevelVars declTypes) dataDecls) + return + $ Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) + where + makeFixBody :: TypeMap + -> Coq.Qualid + -> IR.Type + -> IR.TypeDecl + -> Converter Coq.FixBody + makeFixBody m var t decl = do + rhs <- generateBody m var decl t + (binders, retType) <- makeNFBindersAndReturnType' t var + return + $ Coq.FixBody (fromJust (lookupType t m)) (NonEmpty.fromList binders) + Nothing (Just retType) rhs + + generateBody + :: TypeMap + -> Coq.Qualid + -> IR.TypeDecl + -> IR.Type + -> Converter Coq.Term -- TODO: don't do that. Sort these functions properly. + + generateBody topLevelMap ident tDecl t = do + let ts = nub + (reverse (concatMap (collectSubTypes conNames) + (concatMap IR.conDeclFields (IR.dataDeclCons tDecl)))) + let recTypes = filter (\t -> not (t `elem` declTypes || isTypeVar t)) ts + let typeVars = map (Coq.bare . IR.typeVarDeclIdent) + (IR.typeDeclArgs tDecl) + targetVars <- (map Coq.bare) + <$> replicateM (length typeVars) (freshCoqIdent "b") + let freeQualids = map fst Coq.Base.freeArgs + normalformFuncMap <- nameFunctionsAndInsert "nf'" topLevelMap recTypes + nf'Body <- generateNf'Body normalformFuncMap ident t recTypes + return nf'Body + + -- letfix distinction + generateNf'Body + :: TypeMap -> Coq.Qualid -> IR.Type -> [IR.Type] -> Converter Coq.Term + generateNf'Body m ident t [] = matchConstructors m ident t + generateNf'Body m ident t (recType : recTypes) = do + inBody <- generateNf'Body m ident t recTypes + var <- Coq.bare <$> freshCoqIdent "x" + letBody <- matchConstructors m var recType + (binders, retType) <- makeNFBindersAndReturnType' recType var + let Just localFuncName = lookupType recType m + return + $ Coq.Let localFuncName [] Nothing + (Coq.Fix (Coq.FixOne + (Coq.FixBody localFuncName (NonEmpty.fromList binders) Nothing + (Just retType) letBody))) inBody + + matchConstructors :: TypeMap -> Coq.Qualid -> IR.Type -> Converter Coq.Term + matchConstructors m ident t = do + let Just conName = getTypeConName t + entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName + equations <- mapM (buildEquation m t) (entryConsNames entry) + return $ Coq.match (Coq.Qualid ident) equations + + -- type: type expression for unification + -- consName : data constructor name of type + buildEquation + :: TypeMap + -> IR.Type + -> IR.ConName + -> Converter Coq.Equation -- TODO: rename type args before unification + + buildEquation m t conName = do + conEntry <- lookupEntryOrFail NoSrcSpan IR.ValueScope conName + let retType = entryReturnType conEntry + let conIdent = entryIdent conEntry -- :: Qualid + conArgIdents <- (map Coq.bare) + <$> replicateM (entryArity conEntry) (freshCoqIdent "fx") + subst <- unifyOrFail NoSrcSpan t retType + let modArgTypes = map ((stripType conNames) . (applySubst subst)) + (entryArgTypes conEntry) + let lhs = Coq.ArgsPat conIdent (map Coq.QualidPat conArgIdents) + rhs <- buildNormalformValue m conIdent [] (zip modArgTypes conArgIdents) + return $ Coq.equation lhs rhs + + -- TODO: Split into normal function and helper function because of the accumulator. + buildNormalformValue :: TypeMap + -> Coq.Qualid + -> [Coq.Qualid] + -> [(IR.Type, Coq.Qualid)] + -> Converter Coq.Term + buildNormalformValue nameMap consName vals [] = return + $ applyPure (Coq.app (Coq.Qualid consName) + (map (applyPure . Coq.Qualid) (reverse vals))) + buildNormalformValue nameMap consName vals ((t, varName) : consVars) + = case lookupType t nameMap of + Just funcName -> do + x <- Coq.bare <$> freshCoqIdent "x" + nx <- Coq.bare <$> freshCoqIdent "nx" + rhs <- buildNormalformValue nameMap consName (nx : vals) consVars + let c = Coq.fun [nx] [Nothing] rhs + let c'' = applyBind (Coq.app (Coq.Qualid funcName) [(Coq.Qualid x)]) c + return $ applyBind (Coq.Qualid varName) (Coq.fun [x] [Nothing] c'') + Nothing -> do + nx <- Coq.bare <$> freshCoqIdent "nx" + rhs <- buildNormalformValue nameMap consName (nx : vals) consVars + let cont = Coq.fun [nx] [Nothing] rhs + return + $ applyBind (Coq.app (Coq.Qualid (Coq.bare "nf")) + [(Coq.Qualid varName)]) cont showPrettyType :: IR.Type -> Converter String -showPrettyType (IR.TypeVar _ varName) = return (showPretty varName) +showPrettyType (IR.TypeVar _ varName) = return (showPretty varName) showPrettyType (IR.TypeCon srcSpan conName) = do - entry <- lookupEntryOrFail srcSpan IR.TypeScope conName - let Just coqIdent = Coq.unpackQualid (entryIdent entry) - return coqIdent -showPrettyType (IR.TypeApp _ l r) = do - lPretty <- showPrettyType l - rPretty <- showPrettyType r - return (lPretty ++ rPretty) - -collectSubTypes :: [ IR.ConName ] -> IR.Type -> [ IR.Type ] + entry <- lookupEntryOrFail srcSpan IR.TypeScope conName + let Just coqIdent = Coq.unpackQualid (entryIdent entry) + return coqIdent +showPrettyType (IR.TypeApp _ l r) = do + lPretty <- showPrettyType l + rPretty <- showPrettyType r + return (lPretty ++ rPretty) + +collectSubTypes :: [IR.ConName] -> IR.Type -> [IR.Type] collectSubTypes = collectFullyAppliedTypes True -collectFullyAppliedTypes :: Bool -> [ IR.ConName ] -> IR.Type -> [ IR.Type ] +collectFullyAppliedTypes :: Bool -> [IR.ConName] -> IR.Type -> [IR.Type] collectFullyAppliedTypes fullApplication conNames t@(IR.TypeApp _ l r) - | fullApplication = stripType conNames t : collectFullyAppliedTypes False - conNames l ++ collectFullyAppliedTypes True conNames r - | otherwise = collectFullyAppliedTypes False conNames l - ++ collectFullyAppliedTypes True conNames r + | fullApplication = stripType conNames t + : collectFullyAppliedTypes False conNames l + ++ collectFullyAppliedTypes True conNames r + | otherwise = collectFullyAppliedTypes False conNames l + ++ collectFullyAppliedTypes True conNames r collectFullyAppliedTypes _ conNames t = [] -- returns the same type with all 'don't care' types replaced by the variable "_" stripType cs t = stripType' t cs False -stripType' :: IR.Type -> [ IR.ConName ] -> Bool -> IR.Type -stripType' (IR.TypeVar _ _) names flag = IR.TypeVar NoSrcSpan "_" +stripType' :: IR.Type -> [IR.ConName] -> Bool -> IR.Type +stripType' (IR.TypeVar _ _) names flag = IR.TypeVar NoSrcSpan "_" stripType' (IR.TypeCon _ conName) names flag - | flag || conName `elem` names = IR.TypeCon NoSrcSpan conName - | otherwise = IR.TypeVar NoSrcSpan "_" -stripType' (IR.TypeApp _ l r) names flag = case stripType' r names False of - r'@(IR.TypeVar _ _) -> IR.TypeApp NoSrcSpan (stripType' l names flag) r' - r' -> IR.TypeApp NoSrcSpan (stripType' l names True) r' + | flag || conName `elem` names = IR.TypeCon NoSrcSpan conName + | otherwise = IR.TypeVar NoSrcSpan "_" +stripType' (IR.TypeApp _ l r) names flag = case stripType' r names False of + r'@(IR.TypeVar _ _) -> IR.TypeApp NoSrcSpan (stripType' l names flag) r' + r' -> IR.TypeApp NoSrcSpan (stripType' l names True) r' -nameFunctionsAndInsert :: String -> TypeMap -> [ IR.Type ] -> Converter TypeMap -nameFunctionsAndInsert prefix m ts = localEnv $ foldM - (nameFunctionAndInsert prefix) m ts +nameFunctionsAndInsert :: String -> TypeMap -> [IR.Type] -> Converter TypeMap +nameFunctionsAndInsert prefix m ts = localEnv + $ foldM (nameFunctionAndInsert prefix) m ts nameFunctionAndInsert :: String -> TypeMap -> IR.Type -> Converter TypeMap nameFunctionAndInsert prefix m t = do - name <- nameFunction prefix t - return (insertType t (Coq.bare name) m) + name <- nameFunction prefix t + return (insertType t (Coq.bare name) m) -- Names a function based on a type while avoiding name clashes with other -- identifiers. nameFunction :: String -> IR.Type -> Converter String nameFunction prefix t = do - prettyType <- showPrettyType t - freshCoqIdent (prefix ++ prettyType) + prettyType <- showPrettyType t + freshCoqIdent (prefix ++ prettyType) dataDeclToType :: IR.TypeDecl -> IR.Type dataDeclToType dataDecl = IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) - (replicate (length (IR.typeDeclArgs dataDecl)) (IR.TypeVar NoSrcSpan "_")) + (replicate (length (IR.typeDeclArgs dataDecl)) (IR.TypeVar NoSrcSpan "_")) isTypeVar :: IR.Type -> Bool isTypeVar (IR.TypeVar _ _) = True -isTypeVar _ = False +isTypeVar _ = False -- duplicate of CompletePatternPass getTypeConName :: IR.Type -> Maybe IR.ConName @@ -400,80 +415,80 @@ getTypeConName (IR.TypeCon _ conName) = Just conName getTypeConName (IR.TypeApp _ l r) = getTypeConName l getTypeConName _ = Nothing -buildConstraint :: String -> [ Coq.Qualid ] -> Coq.Binder +buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder buildConstraint ident args = Coq.Generalized Coq.Implicit - (Coq.app (Coq.Qualid (Coq.bare ident)) - ((map (Coq.Qualid . fst) Coq.Base.freeArgs) ++ (map Coq.Qualid args))) + (Coq.app (Coq.Qualid (Coq.bare ident)) + ((map (Coq.Qualid . fst) Coq.Base.freeArgs) ++ (map Coq.Qualid args))) -- Coq AST helper functions -freeArgsBinders :: [ Coq.Binder ] +freeArgsBinders :: [Coq.Binder] freeArgsBinders = map (uncurry (Coq.typedBinder' Coq.Implicit)) - Coq.Base.freeArgs + Coq.Base.freeArgs -typeBinder :: [ Coq.Qualid ] -> Coq.Binder +typeBinder :: [Coq.Qualid] -> Coq.Binder typeBinder typeVars = Coq.typedBinder Coq.Implicit typeVars Coq.sortType -- TODO: Does this exist somewhere? applyPure :: Coq.Term -> Coq.Term -applyPure t = Coq.app (Coq.Qualid Coq.Base.freePureCon) [ t ] +applyPure t = Coq.app (Coq.Qualid Coq.Base.freePureCon) [t] applyBind :: Coq.Term -> Coq.Term -> Coq.Term -applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [ mx, f ] +applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [mx, f] -- Given an A, returns Free Shape Pos A applyFree :: Coq.Term -> Coq.Term applyFree a = Coq.app (Coq.Qualid Coq.Base.free) - ((map (Coq.Qualid . fst) Coq.Base.freeArgs) ++ [ a ]) - -shapeAndPos :: [ Coq.Term ] + ((map (Coq.Qualid . fst) Coq.Base.freeArgs) ++ [a]) + +shapeAndPos :: [Coq.Term] shapeAndPos = map (Coq.Qualid . fst) Coq.Base.freeArgs -idShapeAndPos :: [ Coq.Term ] -idShapeAndPos - = (map (Coq.Qualid . Coq.bare) [ "Identity.Shape", "Identity.Pos" ]) +idShapeAndPos :: [Coq.Term] +idShapeAndPos = (map (Coq.Qualid . Coq.bare) ["Identity.Shape", "Identity.Pos"]) -- converts our type into a Coq type (a term) with new variables for all don't care values -toCoqType :: String - -> [ Coq.Term ] -> IR.Type -> Converter ( Coq.Term, [ Coq.Qualid ] ) -toCoqType varPrefix _ (IR.TypeVar _ _) = do - x <- Coq.bare <$> freshCoqIdent varPrefix - return ( Coq.Qualid x, [ x ] ) +toCoqType + :: String -> [Coq.Term] -> IR.Type -> Converter (Coq.Term, [Coq.Qualid]) +toCoqType varPrefix _ (IR.TypeVar _ _) = do + x <- Coq.bare <$> freshCoqIdent varPrefix + return (Coq.Qualid x, [x]) toCoqType varPrefix shapeAndPos (IR.TypeCon _ conName) = do - entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName - return ( Coq.app (Coq.Qualid (entryIdent entry)) shapeAndPos, [] ) -toCoqType varPrefix shapeAndPos (IR.TypeApp _ l r) = do - ( l', varsl ) <- toCoqType varPrefix shapeAndPos l - ( r', varsr ) <- toCoqType varPrefix shapeAndPos r - return ( Coq.app l' [ r' ], varsl ++ varsr ) + entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName + return (Coq.app (Coq.Qualid (entryIdent entry)) shapeAndPos, []) +toCoqType varPrefix shapeAndPos (IR.TypeApp _ l r) = do + (l', varsl) <- toCoqType varPrefix shapeAndPos l + (r', varsr) <- toCoqType varPrefix shapeAndPos r + return (Coq.app l' [r'], varsl ++ varsr) makeNFBindersAndReturnType' - :: IR.Type -> Coq.Qualid -> Converter ( [ Coq.Binder ], Coq.Term ) + :: IR.Type -> Coq.Qualid -> Converter ([Coq.Binder], Coq.Term) makeNFBindersAndReturnType' t varName = do - ( binders, sourceType, targetType ) <- makeNFBindersAndReturnType t - let binders' = binders - ++ [ (Coq.typedBinder' Coq.Explicit varName sourceType) ] - let retType = applyFree targetType - return ( binders', retType ) + (binders, sourceType, targetType) <- makeNFBindersAndReturnType t + let binders' = binders + ++ [(Coq.typedBinder' Coq.Explicit varName sourceType)] + let retType = applyFree targetType + return (binders', retType) makeNFInstanceBindersAndReturnType - :: IR.Type -> Converter ( [ Coq.Binder ], Coq.Term ) + :: IR.Type -> Converter ([Coq.Binder], Coq.Term) makeNFInstanceBindersAndReturnType t = do - ( binders, sourceType, targetType ) <- makeNFBindersAndReturnType t - let retType = Coq.app (Coq.Qualid (Coq.bare "Normalform")) - (shapeAndPos ++ [ sourceType, targetType ]) - return ( binders, retType ) + (binders, sourceType, targetType) <- makeNFBindersAndReturnType t + let retType = Coq.app (Coq.Qualid (Coq.bare "Normalform")) + (shapeAndPos ++ [sourceType, targetType]) + return (binders, retType) -- makes appropriate binders and return type for a (possibly local) nf' function makeNFBindersAndReturnType - :: IR.Type -> Converter ( [ Coq.Binder ], Coq.Term, Coq.Term ) + :: IR.Type -> Converter ([Coq.Binder], Coq.Term, Coq.Term) makeNFBindersAndReturnType t = do - ( sourceType, sourceVars ) <- toCoqType "a" shapeAndPos t - ( targetType, targetVars ) <- toCoqType "b" idShapeAndPos t - let constraints = map (buildConstraint "Normalform") - (zipWith (\v1 v2 -> [ v1 ] ++ [ v2 ]) sourceVars targetVars) - let binders = freeArgsBinders ++ [ typeBinder (sourceVars ++ targetVars) ] - ++ constraints - return ( binders, sourceType, targetType ) + (sourceType, sourceVars) <- toCoqType "a" shapeAndPos t + (targetType, targetVars) <- toCoqType "b" idShapeAndPos t + let constraints = map (buildConstraint "Normalform") + (zipWith (\v1 v2 -> [v1] ++ [v2]) sourceVars targetVars) + let binders = freeArgsBinders + ++ [typeBinder (sourceVars ++ targetVars)] + ++ constraints + return (binders, sourceType, targetType) type TypeMap = IR.Type -> Maybe Coq.Qualid From 7672eee3acfcd6bb631ccd62fac47fd1709c8fb2 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Thu, 27 Aug 2020 16:35:16 +0200 Subject: [PATCH 006/120] Refactor code #150 --- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 184 +++++++++++------- 1 file changed, 118 insertions(+), 66 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index b35bda3a..8e4f96de 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -208,6 +208,8 @@ convertDataDecl (IR.TypeSynDecl _ _ _ _) = error "convertDataDecl: Type synonym not allowed." ------ Instance generation ------- +-- TODO: Make a central function that takes certain parameters (identifiers, type class arguments, buildValue) +-- and automatically creates an entire instance (for functions of type A -> Free Shape Pos A or possibly even A -> B) generateInstances :: [IR.TypeDecl] -> Converter [Coq.Sentence] generateInstances dataDecls = do nfInstances <- generateNormalformInstances @@ -217,11 +219,11 @@ generateInstances dataDecls = do conNames = map IR.typeDeclQName dataDecls + generateNormalformInstances :: Converter [Coq.Sentence] generateNormalformInstances = do topLevelMap <- nameFunctionsAndInsert "nf'" emptyTypeMap declTypes - topLevelVars <- map Coq.bare - <$> mapM freshCoqIdent (replicate (length declTypes) "x") + topLevelVars <- freshQualids (length declTypes) "x" nf' <- generateNf' topLevelMap dataDecls declTypes topLevelVars instances <- mapM (buildInstance topLevelMap) declTypes return (nf' : instances) @@ -265,17 +267,16 @@ generateInstances dataDecls = do -> Coq.Qualid -> IR.TypeDecl -> IR.Type - -> Converter Coq.Term -- TODO: don't do that. Sort these functions properly. + -> Converter Coq.Term generateBody topLevelMap ident tDecl t = do let ts = nub - (reverse (concatMap (collectSubTypes conNames) + (reverse (concatMap collectSubTypes (concatMap IR.conDeclFields (IR.dataDeclCons tDecl)))) let recTypes = filter (\t -> not (t `elem` declTypes || isTypeVar t)) ts let typeVars = map (Coq.bare . IR.typeVarDeclIdent) (IR.typeDeclArgs tDecl) - targetVars <- (map Coq.bare) - <$> replicateM (length typeVars) (freshCoqIdent "b") + targetVars <- freshQualids (length typeVars) "b" let freeQualids = map fst Coq.Base.freeArgs normalformFuncMap <- nameFunctionsAndInsert "nf'" topLevelMap recTypes nf'Body <- generateNf'Body normalformFuncMap ident t recTypes @@ -316,10 +317,9 @@ generateInstances dataDecls = do conEntry <- lookupEntryOrFail NoSrcSpan IR.ValueScope conName let retType = entryReturnType conEntry let conIdent = entryIdent conEntry -- :: Qualid - conArgIdents <- (map Coq.bare) - <$> replicateM (entryArity conEntry) (freshCoqIdent "fx") + conArgIdents <- freshQualids (entryArity conEntry) "fx" subst <- unifyOrFail NoSrcSpan t retType - let modArgTypes = map ((stripType conNames) . (applySubst subst)) + let modArgTypes = map (stripType . (applySubst subst)) (entryArgTypes conEntry) let lhs = Coq.ArgsPat conIdent (map Coq.QualidPat conArgIdents) rhs <- buildNormalformValue m conIdent [] (zip modArgTypes conArgIdents) @@ -351,88 +351,99 @@ generateInstances dataDecls = do $ applyBind (Coq.app (Coq.Qualid (Coq.bare "nf")) [(Coq.Qualid varName)]) cont + ------- Type analysis ------- + + -- This function collects all fully-applied type constructors + -- of arity at least 1 (including their arguments) that occur in the given type. + -- All arguments that do not contain occurrences of the types for which + -- we are defining an instance are replaced by the type variable "_". + -- The resulting list contains (in reverse topological order) exactly all + -- types for which we must define a separate function in the instance + -- definition, where all occurrences of "_" represent the polymorphic + -- components of the function. + collectSubTypes :: IR.Type -> [IR.Type] + collectSubTypes = collectFullyAppliedTypes True + + collectFullyAppliedTypes :: Bool -> IR.Type -> [IR.Type] + collectFullyAppliedTypes fullApplication t@(IR.TypeApp _ l r) + | fullApplication = stripType t + : collectFullyAppliedTypes False l + ++ collectFullyAppliedTypes True r + | otherwise = collectFullyAppliedTypes False l + ++ collectFullyAppliedTypes True r + -- Type variables, function types and type constructors with arity 0 are not + -- collected. + collectFullyAppliedTypes _ _ = [] + + -- returns the same type with all 'don't care' types replaced by the variable "_" + stripType :: IR.Type -> IR.Type + stripType t = stripType' t False + + stripType' :: IR.Type -> Bool -> IR.Type + stripType' (IR.TypeCon _ conName) flag + | flag || conName `elem` conNames = IR.TypeCon NoSrcSpan conName + | otherwise = IR.TypeVar NoSrcSpan "_" + stripType' (IR.TypeApp _ l r) flag = case stripType' r False of + r'@(IR.TypeVar _ _) -> IR.TypeApp NoSrcSpan (stripType' l flag) r' + r' -> IR.TypeApp NoSrcSpan (stripType' l True) r' + -- Type variables and function types are not relevant and are replaced by "_". + stripType' _ _ = IR.TypeVar NoSrcSpan "_" + +-- Like showPretty, but uses the Coq identifiers of the type and its components. showPrettyType :: IR.Type -> Converter String +-- For a type variable, show its name. showPrettyType (IR.TypeVar _ varName) = return (showPretty varName) -showPrettyType (IR.TypeCon srcSpan conName) = do - entry <- lookupEntryOrFail srcSpan IR.TypeScope conName - let Just coqIdent = Coq.unpackQualid (entryIdent entry) - return coqIdent +-- For a type constructor, return its Coq identifier as a string. +showPrettyType (IR.TypeCon _ conName) = + fromJust . (>>= Coq.unpackQualid) <$> (inEnv $ lookupIdent IR.TypeScope conName) +-- For a type application, convert both sides and concatenate them. showPrettyType (IR.TypeApp _ l r) = do lPretty <- showPrettyType l rPretty <- showPrettyType r return (lPretty ++ rPretty) +-- Function types should have been converted into variables. +showPrettyType (IR.FuncType _ _ _) = error "Function types should have been eliminated!" -collectSubTypes :: [IR.ConName] -> IR.Type -> [IR.Type] -collectSubTypes = collectFullyAppliedTypes True - -collectFullyAppliedTypes :: Bool -> [IR.ConName] -> IR.Type -> [IR.Type] -collectFullyAppliedTypes fullApplication conNames t@(IR.TypeApp _ l r) - | fullApplication = stripType conNames t - : collectFullyAppliedTypes False conNames l - ++ collectFullyAppliedTypes True conNames r - | otherwise = collectFullyAppliedTypes False conNames l - ++ collectFullyAppliedTypes True conNames r -collectFullyAppliedTypes _ conNames t = [] - --- returns the same type with all 'don't care' types replaced by the variable "_" -stripType cs t = stripType' t cs False - -stripType' :: IR.Type -> [IR.ConName] -> Bool -> IR.Type -stripType' (IR.TypeVar _ _) names flag = IR.TypeVar NoSrcSpan "_" -stripType' (IR.TypeCon _ conName) names flag - | flag || conName `elem` names = IR.TypeCon NoSrcSpan conName - | otherwise = IR.TypeVar NoSrcSpan "_" -stripType' (IR.TypeApp _ l r) names flag = case stripType' r names False of - r'@(IR.TypeVar _ _) -> IR.TypeApp NoSrcSpan (stripType' l names flag) r' - r' -> IR.TypeApp NoSrcSpan (stripType' l names True) r' - -nameFunctionsAndInsert :: String -> TypeMap -> [IR.Type] -> Converter TypeMap -nameFunctionsAndInsert prefix m ts = localEnv - $ foldM (nameFunctionAndInsert prefix) m ts - -nameFunctionAndInsert :: String -> TypeMap -> IR.Type -> Converter TypeMap -nameFunctionAndInsert prefix m t = do - name <- nameFunction prefix t - return (insertType t (Coq.bare name) m) - --- Names a function based on a type while avoiding name clashes with other --- identifiers. -nameFunction :: String -> IR.Type -> Converter String -nameFunction prefix t = do - prettyType <- showPrettyType t - freshCoqIdent (prefix ++ prettyType) - +-- Converts a data declaration to a type by applying its constructor to the +-- correct number of variables, denoted by underscores. dataDeclToType :: IR.TypeDecl -> IR.Type dataDeclToType dataDecl = IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) (replicate (length (IR.typeDeclArgs dataDecl)) (IR.TypeVar NoSrcSpan "_")) +-- Returns whether a type is a type variable. isTypeVar :: IR.Type -> Bool isTypeVar (IR.TypeVar _ _) = True isTypeVar _ = False --- duplicate of CompletePatternPass +-- TODO duplicate of function in CompletePatternPass; move somewhere else. (Most likely to IR.Type.) +-- Returns the leftmost type constructor of a type expression, or nothing +-- if the type is not an (applied) type constructor. getTypeConName :: IR.Type -> Maybe IR.ConName getTypeConName (IR.TypeCon _ conName) = Just conName -getTypeConName (IR.TypeApp _ l r) = getTypeConName l +getTypeConName (IR.TypeApp _ l _) = getTypeConName l getTypeConName _ = Nothing -buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder -buildConstraint ident args = Coq.Generalized Coq.Implicit - (Coq.app (Coq.Qualid (Coq.bare ident)) - ((map (Coq.Qualid . fst) Coq.Base.freeArgs) ++ (map Coq.Qualid args))) -- Coq AST helper functions +-- TODO: Check if these exist somewhere, and if not, possibly move them +-- somewhere else. + +-- Binders for (implicit) Shape and Pos arguments. +-- freeArgsBinders = [ {Shape : Type}, {Pos : Shape -> Type} ] freeArgsBinders :: [Coq.Binder] freeArgsBinders = map (uncurry (Coq.typedBinder' Coq.Implicit)) Coq.Base.freeArgs +-- Shortcut for the construction of an implicit binder for type variables. +-- typeBinder [a1, ..., an] = {a1 ... an : Type} typeBinder :: [Coq.Qualid] -> Coq.Binder typeBinder typeVars = Coq.typedBinder Coq.Implicit typeVars Coq.sortType --- TODO: Does this exist somewhere? +-- Shortcut for the application of pure. applyPure :: Coq.Term -> Coq.Term applyPure t = Coq.app (Coq.Qualid Coq.Base.freePureCon) [t] +-- Shortcut for the application of >>=. applyBind :: Coq.Term -> Coq.Term -> Coq.Term applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [mx, f] @@ -441,25 +452,36 @@ applyFree :: Coq.Term -> Coq.Term applyFree a = Coq.app (Coq.Qualid Coq.Base.free) ((map (Coq.Qualid . fst) Coq.Base.freeArgs) ++ [a]) +-- [Shape, Pos] shapeAndPos :: [Coq.Term] shapeAndPos = map (Coq.Qualid . fst) Coq.Base.freeArgs +-- [Identity.Shape, Identity.Pos] idShapeAndPos :: [Coq.Term] idShapeAndPos = (map (Coq.Qualid . Coq.bare) ["Identity.Shape", "Identity.Pos"]) --- converts our type into a Coq type (a term) with new variables for all don't care values +-- Constructs a maximally implicit binder (~ type class constraint) +-- buildConstraint name [a1 ... an] = `{name Shape Pos a1 ... an}. +buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder +buildConstraint ident args = Coq.Generalized Coq.Implicit + (Coq.app (Coq.Qualid (Coq.bare ident)) + ((map (Coq.Qualid . fst) Coq.Base.freeArgs) ++ (map Coq.Qualid args))) + +-- converts our type into a Coq type (a term) with new variables for all don't care values. +-- We can also choose the prefix for those variables. toCoqType :: String -> [Coq.Term] -> IR.Type -> Converter (Coq.Term, [Coq.Qualid]) toCoqType varPrefix _ (IR.TypeVar _ _) = do x <- Coq.bare <$> freshCoqIdent varPrefix return (Coq.Qualid x, [x]) -toCoqType varPrefix shapeAndPos (IR.TypeCon _ conName) = do +toCoqType _ _ (IR.TypeCon _ conName) = do entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName return (Coq.app (Coq.Qualid (entryIdent entry)) shapeAndPos, []) -toCoqType varPrefix shapeAndPos (IR.TypeApp _ l r) = do - (l', varsl) <- toCoqType varPrefix shapeAndPos l - (r', varsr) <- toCoqType varPrefix shapeAndPos r +toCoqType varPrefix extraArgs (IR.TypeApp _ l r) = do + (l', varsl) <- toCoqType varPrefix extraArgs l + (r', varsr) <- toCoqType varPrefix extraArgs r return (Coq.app l' [r'], varsl ++ varsr) +toCoqType _ _ (IR.FuncType _ _ _) = error "Function types should have been eliminated." makeNFBindersAndReturnType' :: IR.Type -> Coq.Qualid -> Converter ([Coq.Binder], Coq.Term) @@ -490,7 +512,14 @@ makeNFBindersAndReturnType t = do ++ [typeBinder (sourceVars ++ targetVars)] ++ constraints return (binders, sourceType, targetType) - + +-- Function name map +-- For each type that contains one of the types we are defining +-- an instance for - directly or indirectly -, we insert an +-- entry into a map that returns the name of the function we +-- should call on a value of that type. +-- For all types that do not have a corresponding entry, we +-- can assume that an instance already exists. type TypeMap = IR.Type -> Maybe Coq.Qualid emptyTypeMap :: TypeMap @@ -501,3 +530,26 @@ lookupType = flip ($) insertType :: IR.Type -> Coq.Qualid -> TypeMap -> TypeMap insertType k v m = \t -> if k == t then Just v else m t + +-- Creates an entry with a unique name for each of the given types and +-- inserts them into the given map. +nameFunctionsAndInsert :: String -> TypeMap -> [IR.Type] -> Converter TypeMap +nameFunctionsAndInsert prefix m ts = localEnv + $ foldM (nameFunctionAndInsert prefix) m ts + +-- Like `nameFunctionsAndInsert`, but for a single type. +nameFunctionAndInsert :: String -> TypeMap -> IR.Type -> Converter TypeMap +nameFunctionAndInsert prefix m t = do + name <- nameFunction prefix t + return (insertType t (Coq.bare name) m) + +-- Names a function based on a type while avoiding name clashes with other +-- identifiers. +nameFunction :: String -> IR.Type -> Converter String +nameFunction prefix t = do + prettyType <- showPrettyType t + freshCoqIdent (prefix ++ prettyType) + +-- Produces n new Coq identifiers (Qualids) +freshQualids :: Int -> String -> Converter [Coq.Qualid] +freshQualids n prefix = replicateM n (Coq.bare <$> freshCoqIdent prefix) From 541069153da00ca8ffa2233748cb717876d5e7da Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Thu, 27 Aug 2020 18:58:17 +0200 Subject: [PATCH 007/120] Refactor code and expand type synonyms #150 --- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 8e4f96de..d30d37a2 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -30,6 +30,8 @@ import FreeC.Monad.Converter import FreeC.Monad.Reporter import FreeC.Pretty +import Debug.Trace + ------------------------------------------------------------------------------- -- Strongly Connected Components -- ------------------------------------------------------------------------------- @@ -270,9 +272,11 @@ generateInstances dataDecls = do -> Converter Coq.Term generateBody topLevelMap ident tDecl t = do + let argTypes = concatMap IR.conDeclFields (IR.dataDeclCons tDecl) + argTypesExpanded <- mapM expandAllTypeSynonyms argTypes let ts = nub (reverse (concatMap collectSubTypes - (concatMap IR.conDeclFields (IR.dataDeclCons tDecl)))) + argTypesExpanded)) let recTypes = filter (\t -> not (t `elem` declTypes || isTypeVar t)) ts let typeVars = map (Coq.bare . IR.typeVarDeclIdent) (IR.typeDeclArgs tDecl) @@ -384,7 +388,9 @@ generateInstances dataDecls = do | flag || conName `elem` conNames = IR.TypeCon NoSrcSpan conName | otherwise = IR.TypeVar NoSrcSpan "_" stripType' (IR.TypeApp _ l r) flag = case stripType' r False of - r'@(IR.TypeVar _ _) -> IR.TypeApp NoSrcSpan (stripType' l flag) r' + r'@(IR.TypeVar _ _) -> case stripType' l flag of + (IR.TypeVar _ _) -> IR.TypeVar NoSrcSpan "_" -- makes sure that Don't cares are squashed. + l' ->IR.TypeApp NoSrcSpan l' r' r' -> IR.TypeApp NoSrcSpan (stripType' l True) r' -- Type variables and function types are not relevant and are replaced by "_". stripType' _ _ = IR.TypeVar NoSrcSpan "_" @@ -421,7 +427,7 @@ isTypeVar _ = False getTypeConName :: IR.Type -> Maybe IR.ConName getTypeConName (IR.TypeCon _ conName) = Just conName getTypeConName (IR.TypeApp _ l _) = getTypeConName l -getTypeConName _ = Nothing +getTypeConName t = error $ "No type constructor application: " ++ showPretty t -- TODO: Change -- Coq AST helper functions @@ -474,9 +480,9 @@ toCoqType toCoqType varPrefix _ (IR.TypeVar _ _) = do x <- Coq.bare <$> freshCoqIdent varPrefix return (Coq.Qualid x, [x]) -toCoqType _ _ (IR.TypeCon _ conName) = do +toCoqType _ extraArgs (IR.TypeCon _ conName) = do entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName - return (Coq.app (Coq.Qualid (entryIdent entry)) shapeAndPos, []) + return (Coq.app (Coq.Qualid (entryIdent entry)) extraArgs, []) toCoqType varPrefix extraArgs (IR.TypeApp _ l r) = do (l', varsl) <- toCoqType varPrefix extraArgs l (r', varsr) <- toCoqType varPrefix extraArgs r @@ -508,8 +514,9 @@ makeNFBindersAndReturnType t = do (targetType, targetVars) <- toCoqType "b" idShapeAndPos t let constraints = map (buildConstraint "Normalform") (zipWith (\v1 v2 -> [v1] ++ [v2]) sourceVars targetVars) + let varBinders = if null sourceVars then [] else [typeBinder (sourceVars ++ targetVars)] let binders = freeArgsBinders - ++ [typeBinder (sourceVars ++ targetVars)] + ++ varBinders ++ constraints return (binders, sourceType, targetType) From 29300fcc658babc7be28398ec91eca28eaefb666 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Thu, 27 Aug 2020 23:41:08 +0200 Subject: [PATCH 008/120] Generalize instance generation #150 The program to generate typeclass instances for user-defined Haskell types is now more general. Instances for different typeclasses can now be generated simply by passing a few parameters, namely: - The name of the class - The name of the function provided by the class - A function that generates appropriate binders and return types - A function that builds a concrete value of the return type Currently, only typeclass instances with a certain structure can be generated (for example, the class can currently only contain one function), but it should be quite easy to generate instances for ShareableArgs in addition to Normalform now. --- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 324 +++++++++--------- 1 file changed, 163 insertions(+), 161 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index d30d37a2..34a011a6 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -7,7 +7,6 @@ import Control.Monad import Control.Monad.Extra ( concatMapM ) import Data.List ( nub, partition ) import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map as Map import Data.Maybe ( catMaybes, fromJust ) import qualified Data.Set as Set @@ -30,8 +29,6 @@ import FreeC.Monad.Converter import FreeC.Monad.Reporter import FreeC.Pretty -import Debug.Trace - ------------------------------------------------------------------------------- -- Strongly Connected Components -- ------------------------------------------------------------------------------- @@ -118,7 +115,8 @@ convertTypeSynDecl (IR.DataDecl _ _ _ _) convertDataDecls :: [IR.TypeDecl] -> Converter [Coq.Sentence] convertDataDecls dataDecls = do (indBodies, extraSentences) <- mapAndUnzipM convertDataDecl dataDecls - instances <- generateInstances dataDecls + --instances <- generateInstances dataDecls + instances <- generateAllInstances dataDecls return (Coq.comment ("Data type declarations for " ++ showPretty (map IR.typeDeclName dataDecls)) @@ -210,107 +208,115 @@ convertDataDecl (IR.TypeSynDecl _ _ _ _) = error "convertDataDecl: Type synonym not allowed." ------ Instance generation ------- --- TODO: Make a central function that takes certain parameters (identifiers, type class arguments, buildValue) --- and automatically creates an entire instance (for functions of type A -> Free Shape Pos A or possibly even A -> B) -generateInstances :: [IR.TypeDecl] -> Converter [Coq.Sentence] -generateInstances dataDecls = do - nfInstances <- generateNormalformInstances - return nfInstances +-- builds instances for all available typeclasses (currently Normalform) +generateAllInstances :: [IR.TypeDecl] -> Converter [Coq.Sentence] +generateAllInstances dataDecls = do + let argTypes = map (\tDecl -> concatMap IR.conDeclFields + (IR.dataDeclCons tDecl)) dataDecls -- TODO remove lambda :: [[IR.Type]] + argTypesExpanded + <- mapM (mapM expandAllTypeSynonyms) argTypes -- :: [[IR.Type]] + let types = map (nub . reverse . (concatMap collectSubTypes)) argTypesExpanded + let recTypeList = map (filter (\t -> not (t `elem` declTypes || isTypeVar t))) + types + buildInstances recTypeList "nf'" "Normalform" + nfBindersAndReturnType buildNormalformValue + where declTypes = map dataDeclToType dataDecls conNames = map IR.typeDeclQName dataDecls - - generateNormalformInstances :: Converter [Coq.Sentence] - generateNormalformInstances = do - topLevelMap <- nameFunctionsAndInsert "nf'" emptyTypeMap declTypes - topLevelVars <- freshQualids (length declTypes) "x" - nf' <- generateNf' topLevelMap dataDecls declTypes topLevelVars - instances <- mapM (buildInstance topLevelMap) declTypes - return (nf' : instances) - - buildInstance :: TypeMap -> IR.Type -> Converter Coq.Sentence - buildInstance m t = localEnv $ do - -- @nf' := nf'T@ - let instanceBody = (Coq.bare "nf'", Coq.Qualid (fromJust (lookupType t m))) - -- Get the binders and return type for the instance declaration - (binders, retType) <- makeNFInstanceBindersAndReturnType t - instanceName <- Coq.bare <$> nameFunction "Normalform" t - return - $ Coq.InstanceSentence (Coq.InstanceDefinition instanceName binders - retType [instanceBody] Nothing) - - generateNf' :: TypeMap - -> [IR.TypeDecl] - -> [IR.Type] - -> [Coq.Qualid] - -> Converter Coq.Sentence - generateNf' topLevelMap dataDecls declTypes topLevelVars = localEnv $ do - fixBodies <- mapM (uncurry (uncurry (makeFixBody topLevelMap))) - (zip (zip topLevelVars declTypes) dataDecls) - return - $ Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) + -- makes instances for a specific typeclass + buildInstances + :: [[IR.Type]] -- for each dataDecl, the types contained in it with nested occurrences of one of the dataDecls + -> String -- function prefix, i.e. what functions will be called (e.g. nf' or shareArgs) + -> String -- name of the typeclass + -> (IR.Type + -> Coq.Qualid + -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term)) -- function to get class-specific binders and return types + -> (TypeMap + -> Coq.Qualid + -> [(IR.Type, Coq.Qualid)] + -> Converter Coq.Term) -- how to actually build a value + -> Converter [Coq.Sentence] + buildInstances recTypeList functionPrefix className getBindersAndReturnTypes + buildValue = do + topLevelMap + <- nameFunctionsAndInsert functionPrefix emptyTypeMap declTypes + typeLevelMaps <- mapM (nameFunctionsAndInsert functionPrefix topLevelMap) + recTypeList + -- top-level variables, one for each dataDecl + topLevelVars <- freshQualids (length declTypes) "x" + topLevelBindersAndReturnTypes <- mapM (uncurry getBindersAndReturnTypes) + (zip declTypes topLevelVars) + functionDefinitions <- buildFunctions topLevelVars typeLevelMaps + topLevelBindersAndReturnTypes + instanceDefinitions <- mapM (uncurry (uncurry buildInstance')) + (zip (zip typeLevelMaps declTypes) topLevelBindersAndReturnTypes) + return (functionDefinitions : instanceDefinitions) where - makeFixBody :: TypeMap - -> Coq.Qualid - -> IR.Type - -> IR.TypeDecl - -> Converter Coq.FixBody - makeFixBody m var t decl = do - rhs <- generateBody m var decl t - (binders, retType) <- makeNFBindersAndReturnType' t var + buildInstance' :: TypeMap + -> IR.Type + -> ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) + -> Converter Coq.Sentence + buildInstance' m t (binders, _, _, retType) = localEnv $ do + -- @nf' := nf'T@ + let instanceBody + = (Coq.bare functionPrefix, Coq.Qualid (fromJust (lookupType t m))) + instanceName <- Coq.bare <$> nameFunction className t + return + $ Coq.InstanceSentence (Coq.InstanceDefinition instanceName binders + retType [instanceBody] Nothing) + + buildFunctions :: [Coq.Qualid] + -> [TypeMap] + -> [([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term)] + -> Converter Coq.Sentence + buildFunctions topLevelVars typeLevelMaps topLevelBindersAndReturnTypes = do + fixBodies <- mapM + (uncurry (uncurry (uncurry (uncurry makeFixBody')))) -- TODO Refactor this! + (zip (zip (zip (zip typeLevelMaps topLevelVars) declTypes) + topLevelBindersAndReturnTypes) recTypeList) return - $ Coq.FixBody (fromJust (lookupType t m)) (NonEmpty.fromList binders) - Nothing (Just retType) rhs + $ Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) + + makeFixBody' :: TypeMap + -> Coq.Qualid + -> IR.Type + -> ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) + -> [IR.Type] + -> Converter Coq.FixBody + makeFixBody' m varName t (binders, varBinder, retType, _) recTypes = do + rhs <- generateBody' m varName t recTypes + return + $ Coq.FixBody (fromJust (lookupType t m)) + (NonEmpty.fromList (binders ++ [varBinder])) Nothing (Just retType) rhs - generateBody - :: TypeMap - -> Coq.Qualid - -> IR.TypeDecl - -> IR.Type - -> Converter Coq.Term - - generateBody topLevelMap ident tDecl t = do - let argTypes = concatMap IR.conDeclFields (IR.dataDeclCons tDecl) - argTypesExpanded <- mapM expandAllTypeSynonyms argTypes - let ts = nub - (reverse (concatMap collectSubTypes - argTypesExpanded)) - let recTypes = filter (\t -> not (t `elem` declTypes || isTypeVar t)) ts - let typeVars = map (Coq.bare . IR.typeVarDeclIdent) - (IR.typeDeclArgs tDecl) - targetVars <- freshQualids (length typeVars) "b" - let freeQualids = map fst Coq.Base.freeArgs - normalformFuncMap <- nameFunctionsAndInsert "nf'" topLevelMap recTypes - nf'Body <- generateNf'Body normalformFuncMap ident t recTypes - return nf'Body - - -- letfix distinction - generateNf'Body + generateBody' :: TypeMap -> Coq.Qualid -> IR.Type -> [IR.Type] -> Converter Coq.Term - generateNf'Body m ident t [] = matchConstructors m ident t - generateNf'Body m ident t (recType : recTypes) = do - inBody <- generateNf'Body m ident t recTypes + generateBody' m varName t [] + = matchConstructors m varName t + generateBody' m varName t (recType : recTypes) = do + inBody <- generateBody' m varName t recTypes var <- Coq.bare <$> freshCoqIdent "x" letBody <- matchConstructors m var recType - (binders, retType) <- makeNFBindersAndReturnType' recType var + (binders, varBinder, retType, _) <- getBindersAndReturnTypes recType var let Just localFuncName = lookupType recType m return $ Coq.Let localFuncName [] Nothing - (Coq.Fix (Coq.FixOne - (Coq.FixBody localFuncName (NonEmpty.fromList binders) Nothing - (Just retType) letBody))) inBody + (Coq.Fix (Coq.FixOne (Coq.FixBody localFuncName + (NonEmpty.fromList (binders ++ [varBinder])) + Nothing (Just retType) letBody))) inBody matchConstructors :: TypeMap -> Coq.Qualid -> IR.Type -> Converter Coq.Term - matchConstructors m ident t = do + matchConstructors m varName t = do let Just conName = getTypeConName t entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName equations <- mapM (buildEquation m t) (entryConsNames entry) - return $ Coq.match (Coq.Qualid ident) equations + return $ Coq.match (Coq.Qualid varName) equations - -- type: type expression for unification - -- consName : data constructor name of type + -- type: type expression for unification + -- conName : data constructor name of type buildEquation :: TypeMap -> IR.Type @@ -326,37 +332,10 @@ generateInstances dataDecls = do let modArgTypes = map (stripType . (applySubst subst)) (entryArgTypes conEntry) let lhs = Coq.ArgsPat conIdent (map Coq.QualidPat conArgIdents) - rhs <- buildNormalformValue m conIdent [] (zip modArgTypes conArgIdents) + rhs <- buildValue m conIdent (zip modArgTypes conArgIdents) return $ Coq.equation lhs rhs - -- TODO: Split into normal function and helper function because of the accumulator. - buildNormalformValue :: TypeMap - -> Coq.Qualid - -> [Coq.Qualid] - -> [(IR.Type, Coq.Qualid)] - -> Converter Coq.Term - buildNormalformValue nameMap consName vals [] = return - $ applyPure (Coq.app (Coq.Qualid consName) - (map (applyPure . Coq.Qualid) (reverse vals))) - buildNormalformValue nameMap consName vals ((t, varName) : consVars) - = case lookupType t nameMap of - Just funcName -> do - x <- Coq.bare <$> freshCoqIdent "x" - nx <- Coq.bare <$> freshCoqIdent "nx" - rhs <- buildNormalformValue nameMap consName (nx : vals) consVars - let c = Coq.fun [nx] [Nothing] rhs - let c'' = applyBind (Coq.app (Coq.Qualid funcName) [(Coq.Qualid x)]) c - return $ applyBind (Coq.Qualid varName) (Coq.fun [x] [Nothing] c'') - Nothing -> do - nx <- Coq.bare <$> freshCoqIdent "nx" - rhs <- buildNormalformValue nameMap consName (nx : vals) consVars - let cont = Coq.fun [nx] [Nothing] rhs - return - $ applyBind (Coq.app (Coq.Qualid (Coq.bare "nf")) - [(Coq.Qualid varName)]) cont - ------- Type analysis ------- - -- This function collects all fully-applied type constructors -- of arity at least 1 (including their arguments) that occur in the given type. -- All arguments that do not contain occurrences of the types for which @@ -371,10 +350,9 @@ generateInstances dataDecls = do collectFullyAppliedTypes :: Bool -> IR.Type -> [IR.Type] collectFullyAppliedTypes fullApplication t@(IR.TypeApp _ l r) | fullApplication = stripType t - : collectFullyAppliedTypes False l - ++ collectFullyAppliedTypes True r - | otherwise = collectFullyAppliedTypes False l - ++ collectFullyAppliedTypes True r + : collectFullyAppliedTypes False l ++ collectFullyAppliedTypes True r + | otherwise + = collectFullyAppliedTypes False l ++ collectFullyAppliedTypes True r -- Type variables, function types and type constructors with arity 0 are not -- collected. collectFullyAppliedTypes _ _ = [] @@ -387,28 +365,31 @@ generateInstances dataDecls = do stripType' (IR.TypeCon _ conName) flag | flag || conName `elem` conNames = IR.TypeCon NoSrcSpan conName | otherwise = IR.TypeVar NoSrcSpan "_" - stripType' (IR.TypeApp _ l r) flag = case stripType' r False of + stripType' (IR.TypeApp _ l r) flag = case stripType' r False of r'@(IR.TypeVar _ _) -> case stripType' l flag of - (IR.TypeVar _ _) -> IR.TypeVar NoSrcSpan "_" -- makes sure that Don't cares are squashed. - l' ->IR.TypeApp NoSrcSpan l' r' + (IR.TypeVar _ _) -> IR.TypeVar NoSrcSpan "_" -- makes sure that Don't cares are squashed. + l' -> IR.TypeApp NoSrcSpan l' r' r' -> IR.TypeApp NoSrcSpan (stripType' l True) r' -- Type variables and function types are not relevant and are replaced by "_". stripType' _ _ = IR.TypeVar NoSrcSpan "_" +---------------- Helper functions for types ----------------- -- Like showPretty, but uses the Coq identifiers of the type and its components. showPrettyType :: IR.Type -> Converter String + -- For a type variable, show its name. -showPrettyType (IR.TypeVar _ varName) = return (showPretty varName) +showPrettyType (IR.TypeVar _ varName) = return (showPretty varName) -- For a type constructor, return its Coq identifier as a string. -showPrettyType (IR.TypeCon _ conName) = - fromJust . (>>= Coq.unpackQualid) <$> (inEnv $ lookupIdent IR.TypeScope conName) +showPrettyType (IR.TypeCon _ conName) = fromJust . (>>= Coq.unpackQualid) + <$> (inEnv $ lookupIdent IR.TypeScope conName) -- For a type application, convert both sides and concatenate them. -showPrettyType (IR.TypeApp _ l r) = do +showPrettyType (IR.TypeApp _ l r) = do lPretty <- showPrettyType l rPretty <- showPrettyType r return (lPretty ++ rPretty) -- Function types should have been converted into variables. -showPrettyType (IR.FuncType _ _ _) = error "Function types should have been eliminated!" +showPrettyType (IR.FuncType _ _ _) + = error "Function types should have been eliminated!" -- Converts a data declaration to a type by applying its constructor to the -- correct number of variables, denoted by underscores. @@ -429,11 +410,9 @@ getTypeConName (IR.TypeCon _ conName) = Just conName getTypeConName (IR.TypeApp _ l _) = getTypeConName l getTypeConName t = error $ "No type constructor application: " ++ showPretty t -- TODO: Change - --- Coq AST helper functions +------------------- Coq AST helper functions/shortcuts ------------------- -- TODO: Check if these exist somewhere, and if not, possibly move them -- somewhere else. - -- Binders for (implicit) Shape and Pos arguments. -- freeArgsBinders = [ {Shape : Type}, {Pos : Shape -> Type} ] freeArgsBinders :: [Coq.Binder] @@ -477,49 +456,72 @@ buildConstraint ident args = Coq.Generalized Coq.Implicit -- We can also choose the prefix for those variables. toCoqType :: String -> [Coq.Term] -> IR.Type -> Converter (Coq.Term, [Coq.Qualid]) -toCoqType varPrefix _ (IR.TypeVar _ _) = do +toCoqType varPrefix _ (IR.TypeVar _ _) = do x <- Coq.bare <$> freshCoqIdent varPrefix return (Coq.Qualid x, [x]) -toCoqType _ extraArgs (IR.TypeCon _ conName) = do +toCoqType _ extraArgs (IR.TypeCon _ conName) = do entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName return (Coq.app (Coq.Qualid (entryIdent entry)) extraArgs, []) -toCoqType varPrefix extraArgs (IR.TypeApp _ l r) = do +toCoqType varPrefix extraArgs (IR.TypeApp _ l r) = do (l', varsl) <- toCoqType varPrefix extraArgs l (r', varsr) <- toCoqType varPrefix extraArgs r return (Coq.app l' [r'], varsl ++ varsr) -toCoqType _ _ (IR.FuncType _ _ _) = error "Function types should have been eliminated." - -makeNFBindersAndReturnType' - :: IR.Type -> Coq.Qualid -> Converter ([Coq.Binder], Coq.Term) -makeNFBindersAndReturnType' t varName = do - (binders, sourceType, targetType) <- makeNFBindersAndReturnType t - let binders' = binders - ++ [(Coq.typedBinder' Coq.Explicit varName sourceType)] - let retType = applyFree targetType - return (binders', retType) - -makeNFInstanceBindersAndReturnType - :: IR.Type -> Converter ([Coq.Binder], Coq.Term) -makeNFInstanceBindersAndReturnType t = do - (binders, sourceType, targetType) <- makeNFBindersAndReturnType t - let retType = Coq.app (Coq.Qualid (Coq.bare "Normalform")) - (shapeAndPos ++ [sourceType, targetType]) - return (binders, retType) - --- makes appropriate binders and return type for a (possibly local) nf' function -makeNFBindersAndReturnType - :: IR.Type -> Converter ([Coq.Binder], Coq.Term, Coq.Term) -makeNFBindersAndReturnType t = do +toCoqType _ _ (IR.FuncType _ _ _) + = error "Function types should have been eliminated." + +----------- Functions specific to a typeclass ------------ +------- Functions for building Normalform instances ------- +-- regular binders, top-level variable binder, return type of function belonging to type, class name +nfBindersAndReturnType + :: IR.Type + -> Coq.Qualid + -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) +nfBindersAndReturnType t varName = do (sourceType, sourceVars) <- toCoqType "a" shapeAndPos t (targetType, targetVars) <- toCoqType "b" idShapeAndPos t let constraints = map (buildConstraint "Normalform") (zipWith (\v1 v2 -> [v1] ++ [v2]) sourceVars targetVars) - let varBinders = if null sourceVars then [] else [typeBinder (sourceVars ++ targetVars)] - let binders = freeArgsBinders - ++ varBinders - ++ constraints - return (binders, sourceType, targetType) - + let varBinders = if null sourceVars + then [] + else [typeBinder (sourceVars ++ targetVars)] + let binders = freeArgsBinders ++ varBinders ++ constraints + let topLevelVarBinder = Coq.typedBinder' Coq.Explicit varName sourceType + let instanceRetType = Coq.app (Coq.Qualid (Coq.bare "Normalform")) + (shapeAndPos ++ [sourceType, targetType]) + let funcRetType = applyFree targetType + return (binders, topLevelVarBinder, funcRetType, instanceRetType) + +buildNormalformValue + :: TypeMap -> Coq.Qualid -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term +buildNormalformValue = buildNormalformValue' [] + +buildNormalformValue' :: [Coq.Qualid] + -> TypeMap + -> Coq.Qualid + -> [(IR.Type, Coq.Qualid)] + -> Converter Coq.Term +buildNormalformValue' vals _ consName [] = return + $ applyPure (Coq.app (Coq.Qualid consName) + (map (applyPure . Coq.Qualid) (reverse vals))) +buildNormalformValue' vals nameMap consName ((t, varName) : consVars) + = case lookupType t nameMap of + Just funcName -> do + x <- Coq.bare <$> freshCoqIdent "x" + nx <- Coq.bare <$> freshCoqIdent "nx" + rhs <- buildNormalformValue' (nx : vals) nameMap consName consVars + let c = Coq.fun [nx] [Nothing] rhs + let c'' = applyBind (Coq.app (Coq.Qualid funcName) [(Coq.Qualid x)]) c + return $ applyBind (Coq.Qualid varName) (Coq.fun [x] [Nothing] c'') + Nothing -> do + nx <- Coq.bare <$> freshCoqIdent "nx" + rhs <- buildNormalformValue' (nx : vals) nameMap consName consVars + let cont = Coq.fun [nx] [Nothing] rhs + return + $ applyBind (Coq.app (Coq.Qualid (Coq.bare "nf")) + [(Coq.Qualid varName)]) cont + + +------------------------------- -- Function name map -- For each type that contains one of the types we are defining -- an instance for - directly or indirectly -, we insert an @@ -556,7 +558,7 @@ nameFunction :: String -> IR.Type -> Converter String nameFunction prefix t = do prettyType <- showPrettyType t freshCoqIdent (prefix ++ prettyType) - + -- Produces n new Coq identifiers (Qualids) freshQualids :: Int -> String -> Converter [Coq.Qualid] freshQualids n prefix = replicateM n (Coq.bare <$> freshCoqIdent prefix) From 99d83090a6052b38542ec1e07e56dedcb5bce1bd Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 30 Aug 2020 17:11:24 +0200 Subject: [PATCH 009/120] Use fresh variables for unification and adjust local environments #150 Before the return type of a data constructor is unified with a type expression, all variables (underscores) in the type expression are replaced with fresh variables to prevent unification failures. Additionally, the naming of the instance and top-level functions is now done outside of a local environment so that those names are registered globally and no name clashes can occur. Local functions and variables are still named inside a local environment. --- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 45 ++++++++++++++----- 1 file changed, 34 insertions(+), 11 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 34a011a6..4abf0180 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -241,16 +241,22 @@ generateAllInstances dataDecls = do -> Converter [Coq.Sentence] buildInstances recTypeList functionPrefix className getBindersAndReturnTypes buildValue = do + -- The names of the top-level functions must be defined outside of a local + -- environment to prevent any clashes with other names. topLevelMap <- nameFunctionsAndInsert functionPrefix emptyTypeMap declTypes - typeLevelMaps <- mapM (nameFunctionsAndInsert functionPrefix topLevelMap) - recTypeList -- top-level variables, one for each dataDecl - topLevelVars <- freshQualids (length declTypes) "x" - topLevelBindersAndReturnTypes <- mapM (uncurry getBindersAndReturnTypes) - (zip declTypes topLevelVars) - functionDefinitions <- buildFunctions topLevelVars typeLevelMaps - topLevelBindersAndReturnTypes + (typeLevelMaps, topLevelBindersAndReturnTypes, functionDefinitions) <- (localEnv $ do + typeLevelMaps <- mapM (nameFunctionsAndInsert functionPrefix topLevelMap) + recTypeList + topLevelVars <- freshQualids (length declTypes) "x" + topLevelBindersAndReturnTypes <- mapM (uncurry getBindersAndReturnTypes) + (zip declTypes topLevelVars) + funcDefs <- buildFunctions topLevelVars typeLevelMaps + topLevelBindersAndReturnTypes + return (typeLevelMaps, topLevelBindersAndReturnTypes, funcDefs)) + -- The instance must also be defined outside of a local environment so + -- that the instance name does not clash with any other names. instanceDefinitions <- mapM (uncurry (uncurry buildInstance')) (zip (zip typeLevelMaps declTypes) topLevelBindersAndReturnTypes) return (functionDefinitions : instanceDefinitions) @@ -259,7 +265,7 @@ generateAllInstances dataDecls = do -> IR.Type -> ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) -> Converter Coq.Sentence - buildInstance' m t (binders, _, _, retType) = localEnv $ do + buildInstance' m t (binders, _, _, retType) = do -- @nf' := nf'T@ let instanceBody = (Coq.bare functionPrefix, Coq.Qualid (fromJust (lookupType t m))) @@ -328,7 +334,9 @@ generateAllInstances dataDecls = do let retType = entryReturnType conEntry let conIdent = entryIdent conEntry -- :: Qualid conArgIdents <- freshQualids (entryArity conEntry) "fx" - subst <- unifyOrFail NoSrcSpan t retType + -- Replace all underscores with fresh variables before unification. + tFreshVars <- insertFreshVariables t + subst <- unifyOrFail NoSrcSpan tFreshVars retType let modArgTypes = map (stripType . (applySubst subst)) (entryArgTypes conEntry) let lhs = Coq.ArgsPat conIdent (map Coq.QualidPat conArgIdents) @@ -468,6 +476,22 @@ toCoqType varPrefix extraArgs (IR.TypeApp _ l r) = do return (Coq.app l' [r'], varsl ++ varsr) toCoqType _ _ (IR.FuncType _ _ _) = error "Function types should have been eliminated." + + +-- Replaces all variables ("don't care" values) with +-- fresh variables. +insertFreshVariables :: IR.Type -> Converter IR.Type +insertFreshVariables (IR.TypeVar srcSpan _) = do + freshVar <- freshHaskellIdent freshArgPrefix + return (IR.TypeVar srcSpan freshVar) +insertFreshVariables (IR.TypeApp srcSpan l r) = do + lFresh <- insertFreshVariables l + rFresh <- insertFreshVariables r + return (IR.TypeApp srcSpan lFresh rFresh) +-- Type constructors are returned as-is. +-- Function types should not occur, but are also simply returned. +insertFreshVariables t = return t + ----------- Functions specific to a typeclass ------------ ------- Functions for building Normalform instances ------- @@ -543,8 +567,7 @@ insertType k v m = \t -> if k == t then Just v else m t -- Creates an entry with a unique name for each of the given types and -- inserts them into the given map. nameFunctionsAndInsert :: String -> TypeMap -> [IR.Type] -> Converter TypeMap -nameFunctionsAndInsert prefix m ts = localEnv - $ foldM (nameFunctionAndInsert prefix) m ts +nameFunctionsAndInsert prefix m ts = foldM (nameFunctionAndInsert prefix) m ts -- Like `nameFunctionsAndInsert`, but for a single type. nameFunctionAndInsert :: String -> TypeMap -> IR.Type -> Converter TypeMap From 32a911f68956bfa80b7605fa842cc2d282712484 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 30 Aug 2020 18:11:21 +0200 Subject: [PATCH 010/120] Add helper functions to FreeC.IR.Syntax.Type #150 --- src/lib/FreeC/IR/Syntax/Type.hs | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/src/lib/FreeC/IR/Syntax/Type.hs b/src/lib/FreeC/IR/Syntax/Type.hs index 8f03cacb..9cba7ebe 100644 --- a/src/lib/FreeC/IR/Syntax/Type.hs +++ b/src/lib/FreeC/IR/Syntax/Type.hs @@ -68,6 +68,33 @@ splitFuncType (FuncType _ t1 t2) arity in (t1 : argTypes, returnType) splitFuncType returnType _ = ([], returnType) +-- | Returns the name of the outermost type constructor, or @Nothing@ if there +-- is no such type constructor. +getTypeConName :: Type -> Maybe ConName +getTypeConName (TypeCon _ conName) = Just conName +getTypeConName (TypeApp _ l _) = getTypeConName l +getTypeConName _ = Nothing + +-- | Checks whether the given type is a type variable. +isTypeVar :: Type -> Bool +isTypeVar (TypeVar _ _) = True +isTypeVar _ = False + +-- | Checks whether the given type is a type constructor. +isTypeCon :: Type -> Bool +isTypeCon (TypeCon _ _) = True +isTypeCon _ = False + +-- | Checks whether the given type is a type application. +isTypeApp :: Type -> Bool +isTypeApp (TypeApp _ _ _) = True +isTypeApp _ = False + +-- | Checks whether the given type is a function type. +isFuncType :: Type -> Bool +isFuncType (FuncType _ _ _) = True +isFuncType _ = False + -- | Pretty instance for type expressions. instance Pretty Type where pretty = prettyTypePred 0 From 8dafd903dad2cc382c5abc3aa065aee4706810c4 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 30 Aug 2020 18:12:13 +0200 Subject: [PATCH 011/120] Add smart constructor for qualified Coq names to Coq.Syntax #150 --- src/lib/FreeC/Backend/Coq/Syntax.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/lib/FreeC/Backend/Coq/Syntax.hs b/src/lib/FreeC/Backend/Coq/Syntax.hs index f37ea047..e2cef308 100644 --- a/src/lib/FreeC/Backend/Coq/Syntax.hs +++ b/src/lib/FreeC/Backend/Coq/Syntax.hs @@ -9,6 +9,7 @@ module FreeC.Backend.Coq.Syntax -- * Identifiers , ident , bare + , qualified , unpackQualid -- * Functions , app @@ -65,10 +66,14 @@ blankProof = ProofAdmitted (Text.pack " (* FILL IN HERE *)") ident :: String -> Ident ident = Text.pack --- | Smart constructor for Coq identifiers. +-- | Smart constructor for unqualified Coq identifiers. bare :: String -> Qualid bare = Bare . ident +-- | Smart constructor for qualified Coq identifiers. +qualified :: String -> String -> Qualid +qualified modName name = Qualified (ident modName) (ident name) + -- | Gets the identifier for the given unqualified Coq identifier. Returns -- @Nothing@ if the given identifier is qualified. unpackQualid :: Qualid -> Maybe String From 41a3e661722bd390c752008db62f435f9f8b48ea Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 30 Aug 2020 18:12:59 +0200 Subject: [PATCH 012/120] Add some constants to Coq.Base #150 --- src/lib/FreeC/Backend/Coq/Base.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/lib/FreeC/Backend/Coq/Base.hs b/src/lib/FreeC/Backend/Coq/Base.hs index 19c5d063..14cef4dc 100644 --- a/src/lib/FreeC/Backend/Coq/Base.hs +++ b/src/lib/FreeC/Backend/Coq/Base.hs @@ -11,6 +11,8 @@ module FreeC.Backend.Coq.Base , freeImpureCon , freeBind , freeArgs + , shapeAndPos + , idShapeAndPos -- * Partiality , partial , partialArg @@ -68,6 +70,12 @@ freeArgs = [ (Coq.bare "Shape", Coq.Sort Coq.Type) , Coq.Arrow (Coq.Qualid (Coq.bare "Shape")) (Coq.Sort Coq.Type) ) ] +-- | The names of the parameters that mus be passed to the @Free@ monad. +shapeAndPos :: [Coq.Qualid] +shapeAndPos = map fst freeArgs + +-- | The shape and position function representing the Identity monad. +idShapeAndPos = [Coq.qualified "Identity" "Shape", Coq.qualified "Identity" "Pos"] ------------------------------------------------------------------------------- -- Partiality -- From c9fce322a47b0a42281762481dba8ab697ce7d0b Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 30 Aug 2020 18:14:02 +0200 Subject: [PATCH 013/120] Use helper function from IR.Syntax.Type in CompletePatternPass #150 --- src/lib/FreeC/Pass/CompletePatternPass.hs | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/src/lib/FreeC/Pass/CompletePatternPass.hs b/src/lib/FreeC/Pass/CompletePatternPass.hs index 419cde27..0b0efffb 100644 --- a/src/lib/FreeC/Pass/CompletePatternPass.hs +++ b/src/lib/FreeC/Pass/CompletePatternPass.hs @@ -101,7 +101,7 @@ checkPatternFuncDecl funcDecl = checkPatternExpr (IR.funcDeclRhs funcDecl) -- The usage of 'fromJust' is safe, because all types are annotated. let tau = fromJust $ IR.exprType exprScrutinee tau' <- expandAllTypeSynonyms tau - case getTypeConName tau' of + case IR.getTypeConName tau' of Nothing -> failedPatternCheck srcSpan Just typeName -> do -- If an entry is found we can assume that it is 'DataEntry' because @@ -136,11 +136,3 @@ checkPatternFuncDecl funcDecl = checkPatternExpr (IR.funcDeclRhs funcDecl) $ Message srcSpan Error $ "Incomplete pattern in function: " ++ showPretty (IR.funcDeclName funcDecl) - - -- | Selects the name of the outermost type constructor from a type. - getTypeConName :: IR.Type -> Maybe IR.TypeConName - getTypeConName (IR.TypeCon _ typeConName) = Just typeConName - getTypeConName (IR.TypeApp _ typeAppLhs _) = getTypeConName typeAppLhs - -- The type of the scrutinee shouldn't be a function or type variable. - getTypeConName IR.TypeVar {} = Nothing - getTypeConName IR.FuncType {} = Nothing From 35051faaefbe885e3046d3d51d09f17d244b49cd Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 30 Aug 2020 18:58:50 +0200 Subject: [PATCH 014/120] Refactor code a little #150 --- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 211 ++++++++---------- 1 file changed, 94 insertions(+), 117 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 4abf0180..946c1dab 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -216,11 +216,10 @@ generateAllInstances dataDecls = do argTypesExpanded <- mapM (mapM expandAllTypeSynonyms) argTypes -- :: [[IR.Type]] let types = map (nub . reverse . (concatMap collectSubTypes)) argTypesExpanded - let recTypeList = map (filter (\t -> not (t `elem` declTypes || isTypeVar t))) - types - buildInstances recTypeList "nf'" "Normalform" - nfBindersAndReturnType buildNormalformValue - + let recTypeList = map + (filter (\t -> not (t `elem` declTypes || IR.isTypeVar t))) types + buildInstances recTypeList "nf'" "Normalform" nfBindersAndReturnType + buildNormalformValue where declTypes = map dataDeclToType dataDecls @@ -246,15 +245,16 @@ generateAllInstances dataDecls = do topLevelMap <- nameFunctionsAndInsert functionPrefix emptyTypeMap declTypes -- top-level variables, one for each dataDecl - (typeLevelMaps, topLevelBindersAndReturnTypes, functionDefinitions) <- (localEnv $ do - typeLevelMaps <- mapM (nameFunctionsAndInsert functionPrefix topLevelMap) - recTypeList - topLevelVars <- freshQualids (length declTypes) "x" - topLevelBindersAndReturnTypes <- mapM (uncurry getBindersAndReturnTypes) - (zip declTypes topLevelVars) - funcDefs <- buildFunctions topLevelVars typeLevelMaps + (typeLevelMaps, topLevelBindersAndReturnTypes, functionDefinitions) + <- (localEnv $ do + typeLevelMaps <- mapM + (nameFunctionsAndInsert functionPrefix topLevelMap) recTypeList + topLevelVars <- freshQualids (length declTypes) "x" + topLevelBindersAndReturnTypes <- mapM + (uncurry getBindersAndReturnTypes) (zip declTypes topLevelVars) + funcDefs <- buildFunctions topLevelVars typeLevelMaps topLevelBindersAndReturnTypes - return (typeLevelMaps, topLevelBindersAndReturnTypes, funcDefs)) + return (typeLevelMaps, topLevelBindersAndReturnTypes, funcDefs)) -- The instance must also be defined outside of a local environment so -- that the instance name does not clash with any other names. instanceDefinitions <- mapM (uncurry (uncurry buildInstance')) @@ -280,30 +280,30 @@ generateAllInstances dataDecls = do -> Converter Coq.Sentence buildFunctions topLevelVars typeLevelMaps topLevelBindersAndReturnTypes = do fixBodies <- mapM - (uncurry (uncurry (uncurry (uncurry makeFixBody')))) -- TODO Refactor this! + (uncurry (uncurry (uncurry (uncurry makeFixBody)))) -- TODO Refactor this! (zip (zip (zip (zip typeLevelMaps topLevelVars) declTypes) topLevelBindersAndReturnTypes) recTypeList) return $ Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) - makeFixBody' :: TypeMap - -> Coq.Qualid - -> IR.Type - -> ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) - -> [IR.Type] - -> Converter Coq.FixBody - makeFixBody' m varName t (binders, varBinder, retType, _) recTypes = do - rhs <- generateBody' m varName t recTypes + makeFixBody :: TypeMap + -> Coq.Qualid + -> IR.Type + -> ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) + -> [IR.Type] + -> Converter Coq.FixBody + makeFixBody m varName t (binders, varBinder, retType, _) recTypes = do + rhs <- generateBody m varName t recTypes return $ Coq.FixBody (fromJust (lookupType t m)) (NonEmpty.fromList (binders ++ [varBinder])) Nothing (Just retType) rhs - generateBody' + generateBody :: TypeMap -> Coq.Qualid -> IR.Type -> [IR.Type] -> Converter Coq.Term - generateBody' m varName t [] + generateBody m varName t [] = matchConstructors m varName t - generateBody' m varName t (recType : recTypes) = do - inBody <- generateBody' m varName t recTypes + generateBody m varName t (recType : recTypes) = do + inBody <- generateBody m varName t recTypes var <- Coq.bare <$> freshCoqIdent "x" letBody <- matchConstructors m var recType (binders, varBinder, retType, _) <- getBindersAndReturnTypes recType var @@ -316,7 +316,7 @@ generateAllInstances dataDecls = do matchConstructors :: TypeMap -> Coq.Qualid -> IR.Type -> Converter Coq.Term matchConstructors m varName t = do - let Just conName = getTypeConName t + let Just conName = IR.getTypeConName t entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName equations <- mapM (buildEquation m t) (entryConsNames entry) return $ Coq.match (Coq.Qualid varName) equations @@ -380,6 +380,56 @@ generateAllInstances dataDecls = do r' -> IR.TypeApp NoSrcSpan (stripType' l True) r' -- Type variables and function types are not relevant and are replaced by "_". stripType' _ _ = IR.TypeVar NoSrcSpan "_" + + +----------- Functions specific to a typeclass ------------ +------- Functions for building Normalform instances ------- +-- regular binders, top-level variable binder, return type of function belonging to type, class name +nfBindersAndReturnType + :: IR.Type + -> Coq.Qualid + -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) +nfBindersAndReturnType t varName = do + (sourceType, sourceVars) <- toCoqType "a" shapeAndPos t + (targetType, targetVars) <- toCoqType "b" idShapeAndPos t + let constraints = map (buildConstraint "Normalform") + (zipWith (\v1 v2 -> [v1] ++ [v2]) sourceVars targetVars) + let varBinders = if null sourceVars + then [] + else [typeBinder (sourceVars ++ targetVars)] + let binders = freeArgsBinders ++ varBinders ++ constraints + let topLevelVarBinder = Coq.typedBinder' Coq.Explicit varName sourceType + let instanceRetType = Coq.app (Coq.Qualid (Coq.bare "Normalform")) + (shapeAndPos ++ [sourceType, targetType]) + let funcRetType = applyFree targetType + return (binders, topLevelVarBinder, funcRetType, instanceRetType) + +buildNormalformValue + :: TypeMap -> Coq.Qualid -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term +buildNormalformValue nameMap consName = buildNormalformValue' [] + where + buildNormalformValue' + :: [Coq.Qualid] -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term + buildNormalformValue' vals [] = do + args <- mapM (generatePure . Coq.Qualid) (reverse vals) + generatePure (Coq.app (Coq.Qualid consName) args) + buildNormalformValue' vals ((t, varName) : consVars) + = case lookupType t nameMap of + Just funcName -> do + x <- Coq.bare <$> freshCoqIdent "x" + nx <- Coq.bare <$> freshCoqIdent "nx" + rhs <- buildNormalformValue' (nx : vals) consVars + let c = Coq.fun [nx] [Nothing] rhs + let c'' = applyBind (Coq.app (Coq.Qualid funcName) [(Coq.Qualid x)]) c + return $ applyBind (Coq.Qualid varName) (Coq.fun [x] [Nothing] c'') + Nothing -> do + nx <- Coq.bare <$> freshCoqIdent "nx" + rhs <- buildNormalformValue' (nx : vals) consVars + let cont = Coq.fun [nx] [Nothing] rhs + return + $ applyBind (Coq.app (Coq.Qualid (Coq.bare "nf")) + [(Coq.Qualid varName)]) cont + ---------------- Helper functions for types ----------------- -- Like showPretty, but uses the Coq identifiers of the type and its components. @@ -397,7 +447,7 @@ showPrettyType (IR.TypeApp _ l r) = do return (lPretty ++ rPretty) -- Function types should have been converted into variables. showPrettyType (IR.FuncType _ _ _) - = error "Function types should have been eliminated!" + = error "Function types should have been eliminated." -- Converts a data declaration to a type by applying its constructor to the -- correct number of variables, denoted by underscores. @@ -405,22 +455,21 @@ dataDeclToType :: IR.TypeDecl -> IR.Type dataDeclToType dataDecl = IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) (replicate (length (IR.typeDeclArgs dataDecl)) (IR.TypeVar NoSrcSpan "_")) --- Returns whether a type is a type variable. -isTypeVar :: IR.Type -> Bool -isTypeVar (IR.TypeVar _ _) = True -isTypeVar _ = False - --- TODO duplicate of function in CompletePatternPass; move somewhere else. (Most likely to IR.Type.) --- Returns the leftmost type constructor of a type expression, or nothing --- if the type is not an (applied) type constructor. -getTypeConName :: IR.Type -> Maybe IR.ConName -getTypeConName (IR.TypeCon _ conName) = Just conName -getTypeConName (IR.TypeApp _ l _) = getTypeConName l -getTypeConName t = error $ "No type constructor application: " ++ showPretty t -- TODO: Change +-- Replaces all variables ("don't care" values) with +-- fresh variables. +insertFreshVariables :: IR.Type -> Converter IR.Type +insertFreshVariables (IR.TypeVar srcSpan _) = do + freshVar <- freshHaskellIdent freshArgPrefix + return (IR.TypeVar srcSpan freshVar) +insertFreshVariables (IR.TypeApp srcSpan l r) = do + lFresh <- insertFreshVariables l + rFresh <- insertFreshVariables r + return (IR.TypeApp srcSpan lFresh rFresh) +-- Type constructors are returned as-is. +-- Function types should not occur, but are also simply returned. +insertFreshVariables t = return t ------------------- Coq AST helper functions/shortcuts ------------------- --- TODO: Check if these exist somewhere, and if not, possibly move them --- somewhere else. -- Binders for (implicit) Shape and Pos arguments. -- freeArgsBinders = [ {Shape : Type}, {Pos : Shape -> Type} ] freeArgsBinders :: [Coq.Binder] @@ -432,10 +481,6 @@ freeArgsBinders = map (uncurry (Coq.typedBinder' Coq.Implicit)) typeBinder :: [Coq.Qualid] -> Coq.Binder typeBinder typeVars = Coq.typedBinder Coq.Implicit typeVars Coq.sortType --- Shortcut for the application of pure. -applyPure :: Coq.Term -> Coq.Term -applyPure t = Coq.app (Coq.Qualid Coq.Base.freePureCon) [t] - -- Shortcut for the application of >>=. applyBind :: Coq.Term -> Coq.Term -> Coq.Term applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [mx, f] @@ -447,13 +492,13 @@ applyFree a = Coq.app (Coq.Qualid Coq.Base.free) -- [Shape, Pos] shapeAndPos :: [Coq.Term] -shapeAndPos = map (Coq.Qualid . fst) Coq.Base.freeArgs +shapeAndPos = map Coq.Qualid Coq.Base.shapeAndPos -- [Identity.Shape, Identity.Pos] idShapeAndPos :: [Coq.Term] -idShapeAndPos = (map (Coq.Qualid . Coq.bare) ["Identity.Shape", "Identity.Pos"]) +idShapeAndPos = map Coq.Qualid Coq.Base.idShapeAndPos --- Constructs a maximally implicit binder (~ type class constraint) +-- Constructs an implicit generalized binder (~ type class constraint). -- buildConstraint name [a1 ... an] = `{name Shape Pos a1 ... an}. buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder buildConstraint ident args = Coq.Generalized Coq.Implicit @@ -476,74 +521,6 @@ toCoqType varPrefix extraArgs (IR.TypeApp _ l r) = do return (Coq.app l' [r'], varsl ++ varsr) toCoqType _ _ (IR.FuncType _ _ _) = error "Function types should have been eliminated." - - --- Replaces all variables ("don't care" values) with --- fresh variables. -insertFreshVariables :: IR.Type -> Converter IR.Type -insertFreshVariables (IR.TypeVar srcSpan _) = do - freshVar <- freshHaskellIdent freshArgPrefix - return (IR.TypeVar srcSpan freshVar) -insertFreshVariables (IR.TypeApp srcSpan l r) = do - lFresh <- insertFreshVariables l - rFresh <- insertFreshVariables r - return (IR.TypeApp srcSpan lFresh rFresh) --- Type constructors are returned as-is. --- Function types should not occur, but are also simply returned. -insertFreshVariables t = return t - - ------------ Functions specific to a typeclass ------------ -------- Functions for building Normalform instances ------- --- regular binders, top-level variable binder, return type of function belonging to type, class name -nfBindersAndReturnType - :: IR.Type - -> Coq.Qualid - -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) -nfBindersAndReturnType t varName = do - (sourceType, sourceVars) <- toCoqType "a" shapeAndPos t - (targetType, targetVars) <- toCoqType "b" idShapeAndPos t - let constraints = map (buildConstraint "Normalform") - (zipWith (\v1 v2 -> [v1] ++ [v2]) sourceVars targetVars) - let varBinders = if null sourceVars - then [] - else [typeBinder (sourceVars ++ targetVars)] - let binders = freeArgsBinders ++ varBinders ++ constraints - let topLevelVarBinder = Coq.typedBinder' Coq.Explicit varName sourceType - let instanceRetType = Coq.app (Coq.Qualid (Coq.bare "Normalform")) - (shapeAndPos ++ [sourceType, targetType]) - let funcRetType = applyFree targetType - return (binders, topLevelVarBinder, funcRetType, instanceRetType) - -buildNormalformValue - :: TypeMap -> Coq.Qualid -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term -buildNormalformValue = buildNormalformValue' [] - -buildNormalformValue' :: [Coq.Qualid] - -> TypeMap - -> Coq.Qualid - -> [(IR.Type, Coq.Qualid)] - -> Converter Coq.Term -buildNormalformValue' vals _ consName [] = return - $ applyPure (Coq.app (Coq.Qualid consName) - (map (applyPure . Coq.Qualid) (reverse vals))) -buildNormalformValue' vals nameMap consName ((t, varName) : consVars) - = case lookupType t nameMap of - Just funcName -> do - x <- Coq.bare <$> freshCoqIdent "x" - nx <- Coq.bare <$> freshCoqIdent "nx" - rhs <- buildNormalformValue' (nx : vals) nameMap consName consVars - let c = Coq.fun [nx] [Nothing] rhs - let c'' = applyBind (Coq.app (Coq.Qualid funcName) [(Coq.Qualid x)]) c - return $ applyBind (Coq.Qualid varName) (Coq.fun [x] [Nothing] c'') - Nothing -> do - nx <- Coq.bare <$> freshCoqIdent "nx" - rhs <- buildNormalformValue' (nx : vals) nameMap consName consVars - let cont = Coq.fun [nx] [Nothing] rhs - return - $ applyBind (Coq.app (Coq.Qualid (Coq.bare "nf")) - [(Coq.Qualid varName)]) cont - ------------------------------- -- Function name map From 32198d6d9d6917d7e364c9e1ca833ac8740d8e74 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 30 Aug 2020 19:20:59 +0200 Subject: [PATCH 015/120] Refactor code some more #150 --- src/lib/FreeC/Backend/Coq/Base.hs | 5 +- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 76 +++++++++---------- 2 files changed, 39 insertions(+), 42 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Base.hs b/src/lib/FreeC/Backend/Coq/Base.hs index 14cef4dc..ef29de8b 100644 --- a/src/lib/FreeC/Backend/Coq/Base.hs +++ b/src/lib/FreeC/Backend/Coq/Base.hs @@ -70,12 +70,15 @@ freeArgs = [ (Coq.bare "Shape", Coq.Sort Coq.Type) , Coq.Arrow (Coq.Qualid (Coq.bare "Shape")) (Coq.Sort Coq.Type) ) ] + -- | The names of the parameters that mus be passed to the @Free@ monad. shapeAndPos :: [Coq.Qualid] shapeAndPos = map fst freeArgs -- | The shape and position function representing the Identity monad. -idShapeAndPos = [Coq.qualified "Identity" "Shape", Coq.qualified "Identity" "Pos"] +idShapeAndPos :: [Coq.Qualid] +idShapeAndPos + = [Coq.qualified "Identity" "Shape", Coq.qualified "Identity" "Pos"] ------------------------------------------------------------------------------- -- Partiality -- diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 946c1dab..dd07eab5 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -3,7 +3,7 @@ module FreeC.Backend.Coq.Converter.TypeDecl where import Control.Monad - ( foldM, mapAndUnzipM, replicateM ) + ( foldM, mapAndUnzipM, replicateM, zipWithM ) import Control.Monad.Extra ( concatMapM ) import Data.List ( nub, partition ) import qualified Data.List.NonEmpty as NonEmpty @@ -211,11 +211,10 @@ convertDataDecl (IR.TypeSynDecl _ _ _ _) -- builds instances for all available typeclasses (currently Normalform) generateAllInstances :: [IR.TypeDecl] -> Converter [Coq.Sentence] generateAllInstances dataDecls = do - let argTypes = map (\tDecl -> concatMap IR.conDeclFields - (IR.dataDeclCons tDecl)) dataDecls -- TODO remove lambda :: [[IR.Type]] + let argTypes = map (concatMap IR.conDeclFields . IR.dataDeclCons) dataDecls -- :: [[IR.Type]] argTypesExpanded <- mapM (mapM expandAllTypeSynonyms) argTypes -- :: [[IR.Type]] - let types = map (nub . reverse . (concatMap collectSubTypes)) argTypesExpanded + let types = map (nub . reverse . concatMap collectSubTypes) argTypesExpanded let recTypeList = map (filter (\t -> not (t `elem` declTypes || IR.isTypeVar t))) types buildInstances recTypeList "nf'" "Normalform" nfBindersAndReturnType @@ -246,26 +245,26 @@ generateAllInstances dataDecls = do <- nameFunctionsAndInsert functionPrefix emptyTypeMap declTypes -- top-level variables, one for each dataDecl (typeLevelMaps, topLevelBindersAndReturnTypes, functionDefinitions) - <- (localEnv $ do - typeLevelMaps <- mapM - (nameFunctionsAndInsert functionPrefix topLevelMap) recTypeList - topLevelVars <- freshQualids (length declTypes) "x" - topLevelBindersAndReturnTypes <- mapM - (uncurry getBindersAndReturnTypes) (zip declTypes topLevelVars) - funcDefs <- buildFunctions topLevelVars typeLevelMaps - topLevelBindersAndReturnTypes - return (typeLevelMaps, topLevelBindersAndReturnTypes, funcDefs)) + <- localEnv $ do + typeLevelMaps <- mapM + (nameFunctionsAndInsert functionPrefix topLevelMap) recTypeList + topLevelVars <- freshQualids (length declTypes) "x" + topLevelBindersAndReturnTypes + <- zipWithM getBindersAndReturnTypes declTypes topLevelVars + funcDefs <- buildFunctions topLevelVars typeLevelMaps + topLevelBindersAndReturnTypes + return (typeLevelMaps, topLevelBindersAndReturnTypes, funcDefs) -- The instance must also be defined outside of a local environment so -- that the instance name does not clash with any other names. - instanceDefinitions <- mapM (uncurry (uncurry buildInstance')) - (zip (zip typeLevelMaps declTypes) topLevelBindersAndReturnTypes) + instanceDefinitions <- zipWithM (uncurry buildInstance) + (zip typeLevelMaps declTypes) topLevelBindersAndReturnTypes return (functionDefinitions : instanceDefinitions) where - buildInstance' :: TypeMap - -> IR.Type - -> ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) - -> Converter Coq.Sentence - buildInstance' m t (binders, _, _, retType) = do + buildInstance :: TypeMap + -> IR.Type + -> ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) + -> Converter Coq.Sentence + buildInstance m t (binders, _, _, retType) = do -- @nf' := nf'T@ let instanceBody = (Coq.bare functionPrefix, Coq.Qualid (fromJust (lookupType t m))) @@ -279,10 +278,10 @@ generateAllInstances dataDecls = do -> [([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term)] -> Converter Coq.Sentence buildFunctions topLevelVars typeLevelMaps topLevelBindersAndReturnTypes = do - fixBodies <- mapM - (uncurry (uncurry (uncurry (uncurry makeFixBody)))) -- TODO Refactor this! - (zip (zip (zip (zip typeLevelMaps topLevelVars) declTypes) - topLevelBindersAndReturnTypes) recTypeList) + fixBodies <- zipWithM + (uncurry (uncurry (uncurry makeFixBody))) -- TODO Refactor more? + (zip (zip (zip typeLevelMaps topLevelVars) declTypes) + topLevelBindersAndReturnTypes) recTypeList return $ Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) @@ -337,7 +336,7 @@ generateAllInstances dataDecls = do -- Replace all underscores with fresh variables before unification. tFreshVars <- insertFreshVariables t subst <- unifyOrFail NoSrcSpan tFreshVars retType - let modArgTypes = map (stripType . (applySubst subst)) + let modArgTypes = map (stripType . applySubst subst) (entryArgTypes conEntry) let lhs = Coq.ArgsPat conIdent (map Coq.QualidPat conArgIdents) rhs <- buildValue m conIdent (zip modArgTypes conArgIdents) @@ -380,8 +379,7 @@ generateAllInstances dataDecls = do r' -> IR.TypeApp NoSrcSpan (stripType' l True) r' -- Type variables and function types are not relevant and are replaced by "_". stripType' _ _ = IR.TypeVar NoSrcSpan "_" - - + ----------- Functions specific to a typeclass ------------ ------- Functions for building Normalform instances ------- -- regular binders, top-level variable binder, return type of function belonging to type, class name @@ -393,10 +391,9 @@ nfBindersAndReturnType t varName = do (sourceType, sourceVars) <- toCoqType "a" shapeAndPos t (targetType, targetVars) <- toCoqType "b" idShapeAndPos t let constraints = map (buildConstraint "Normalform") - (zipWith (\v1 v2 -> [v1] ++ [v2]) sourceVars targetVars) - let varBinders = if null sourceVars - then [] - else [typeBinder (sourceVars ++ targetVars)] + (zipWith (\v1 v2 -> [v1, v2]) sourceVars targetVars) + let varBinders + = [typeBinder (sourceVars ++ targetVars) | not (null sourceVars)] let binders = freeArgsBinders ++ varBinders ++ constraints let topLevelVarBinder = Coq.typedBinder' Coq.Explicit varName sourceType let instanceRetType = Coq.app (Coq.Qualid (Coq.bare "Normalform")) @@ -427,9 +424,8 @@ buildNormalformValue nameMap consName = buildNormalformValue' [] rhs <- buildNormalformValue' (nx : vals) consVars let cont = Coq.fun [nx] [Nothing] rhs return - $ applyBind (Coq.app (Coq.Qualid (Coq.bare "nf")) - [(Coq.Qualid varName)]) cont - + $ applyBind + (Coq.app (Coq.Qualid (Coq.bare "nf")) [Coq.Qualid varName]) cont ---------------- Helper functions for types ----------------- -- Like showPretty, but uses the Coq identifiers of the type and its components. @@ -439,7 +435,7 @@ showPrettyType :: IR.Type -> Converter String showPrettyType (IR.TypeVar _ varName) = return (showPretty varName) -- For a type constructor, return its Coq identifier as a string. showPrettyType (IR.TypeCon _ conName) = fromJust . (>>= Coq.unpackQualid) - <$> (inEnv $ lookupIdent IR.TypeScope conName) + <$> inEnv (lookupIdent IR.TypeScope conName) -- For a type application, convert both sides and concatenate them. showPrettyType (IR.TypeApp _ l r) = do lPretty <- showPrettyType l @@ -487,8 +483,7 @@ applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [mx, f] -- Given an A, returns Free Shape Pos A applyFree :: Coq.Term -> Coq.Term -applyFree a = Coq.app (Coq.Qualid Coq.Base.free) - ((map (Coq.Qualid . fst) Coq.Base.freeArgs) ++ [a]) +applyFree a = Coq.app (Coq.Qualid Coq.Base.free) (shapeAndPos ++ [a]) -- [Shape, Pos] shapeAndPos :: [Coq.Term] @@ -502,8 +497,7 @@ idShapeAndPos = map Coq.Qualid Coq.Base.idShapeAndPos -- buildConstraint name [a1 ... an] = `{name Shape Pos a1 ... an}. buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder buildConstraint ident args = Coq.Generalized Coq.Implicit - (Coq.app (Coq.Qualid (Coq.bare ident)) - ((map (Coq.Qualid . fst) Coq.Base.freeArgs) ++ (map Coq.Qualid args))) + (Coq.app (Coq.Qualid (Coq.bare ident)) (shapeAndPos ++ (map Coq.Qualid args))) -- converts our type into a Coq type (a term) with new variables for all don't care values. -- We can also choose the prefix for those variables. @@ -539,12 +533,12 @@ lookupType :: IR.Type -> TypeMap -> Maybe Coq.Qualid lookupType = flip ($) insertType :: IR.Type -> Coq.Qualid -> TypeMap -> TypeMap -insertType k v m = \t -> if k == t then Just v else m t +insertType k v m t = if k == t then Just v else m t -- Creates an entry with a unique name for each of the given types and -- inserts them into the given map. nameFunctionsAndInsert :: String -> TypeMap -> [IR.Type] -> Converter TypeMap -nameFunctionsAndInsert prefix m ts = foldM (nameFunctionAndInsert prefix) m ts +nameFunctionsAndInsert prefix = foldM (nameFunctionAndInsert prefix) -- Like `nameFunctionsAndInsert`, but for a single type. nameFunctionAndInsert :: String -> TypeMap -> IR.Type -> Converter TypeMap From 039b07ddc9fee5af1fdc81f7fe95ba7a3cb1af7a Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 30 Aug 2020 19:25:15 +0200 Subject: [PATCH 016/120] Remove redundant brackets #150 --- src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index dd07eab5..56d64f42 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -417,7 +417,7 @@ buildNormalformValue nameMap consName = buildNormalformValue' [] nx <- Coq.bare <$> freshCoqIdent "nx" rhs <- buildNormalformValue' (nx : vals) consVars let c = Coq.fun [nx] [Nothing] rhs - let c'' = applyBind (Coq.app (Coq.Qualid funcName) [(Coq.Qualid x)]) c + let c'' = applyBind (Coq.app (Coq.Qualid funcName) [Coq.Qualid x]) c return $ applyBind (Coq.Qualid varName) (Coq.fun [x] [Nothing] c'') Nothing -> do nx <- Coq.bare <$> freshCoqIdent "nx" @@ -497,7 +497,7 @@ idShapeAndPos = map Coq.Qualid Coq.Base.idShapeAndPos -- buildConstraint name [a1 ... an] = `{name Shape Pos a1 ... an}. buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder buildConstraint ident args = Coq.Generalized Coq.Implicit - (Coq.app (Coq.Qualid (Coq.bare ident)) (shapeAndPos ++ (map Coq.Qualid args))) + (Coq.app (Coq.Qualid (Coq.bare ident)) (shapeAndPos ++ map Coq.Qualid args)) -- converts our type into a Coq type (a term) with new variables for all don't care values. -- We can also choose the prefix for those variables. From dfc24ef2c6fa27002b6472f5eddf79eff7ef1212 Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Sun, 30 Aug 2020 20:08:08 +0200 Subject: [PATCH 017/120] Add examples to test generated normalforms in Coq #175 --- example/Proofs/Normalform.hs | 17 ++++ example/Proofs/NormalformProofs.v | 136 ++++++++++++++++++++++++++++++ 2 files changed, 153 insertions(+) create mode 100644 example/Proofs/Normalform.hs create mode 100644 example/Proofs/NormalformProofs.v diff --git a/example/Proofs/Normalform.hs b/example/Proofs/Normalform.hs new file mode 100644 index 00000000..4d9e7987 --- /dev/null +++ b/example/Proofs/Normalform.hs @@ -0,0 +1,17 @@ +-- | This example defines some data types to check whether the [Normalform] +-- instances are generated correctly. + +module Proofs.Normalform where + +-- Basic recursive data type +data MyList a = MyNil | MyCons a (MyList a) + +-- Mutually recursive data types +data Foo a = Foo (Bar a) +data Bar a = Bar (Foo a) | Baz + +-- Data type with 'hidden' recursion +data Tree a = Leaf | Branch a [Tree a] + +-- Data type with multiple type vars +data Map k v = Empty | Entry k v (Map k v) diff --git a/example/Proofs/NormalformProofs.v b/example/Proofs/NormalformProofs.v new file mode 100644 index 00000000..25cb3676 --- /dev/null +++ b/example/Proofs/NormalformProofs.v @@ -0,0 +1,136 @@ +(* This file includes some examples that show the normalisation of + some data types in a nondeterministic context. *) + +From Base Require Import Free. +From Base Require Import Free.Instance.Identity. +From Base Require Import Free.Instance.ND. +From Base Require Import Free.Util.Search. +From Base Require Import Prelude. + +From Generated Require Import Proofs.Normalform. + +Require Import Lists.List. +Import List.ListNotations. + +(* Shortcuts to handle a program. *) + +(* Shortcut to evaluate a non-deterministic program to a result list. + list without normalization. *) +Definition evalND {A : Type} (p : Free _ _ A) +:= @collectVals A (run (runChoice p)). + +(* Handle a non-deterministic program after normalization. *) +Definition evalNDNF {A B : Type} + `{Normalform _ _ A B} + p := evalND (nf p). + +(* Shortcuts for the Identity effect (i.e. the lack of an effect). *) +Notation IdS := Identity.Shape. +Notation IdP := Identity.Pos. + +Section Data. + + Variable Shape : Type. + Variable Pos : Shape -> Type. + + Notation "'ND'" := (Injectable ND.Shape ND.Pos Shape Pos). + + Notation Bool_ := (Bool Shape Pos). + Notation True_ := (True_ Shape Pos). + Notation False_ := (False_ Shape Pos). + + Notation "x ? y" := (Choice Shape Pos x y) (at level 50). + + (* true : ([] ? [true ? false]) *) + Definition ndList `{ND} : Free Shape Pos (MyList Shape Pos Bool_) + := MyCons Shape Pos + True_ + ( MyNil Shape Pos + ? MyCons Shape Pos + (True_ ? False_) + (MyNil Shape Pos)). + + (* (foo (bar (foo baz))) ? (foo baz) *) + Definition ndFoo `{ND} : Free Shape Pos (Foo Shape Pos Bool_) + := Foo0 Shape Pos + ( Bar0 Shape Pos + (Foo0 Shape Pos + (Baz Shape Pos)) + ? Baz Shape Pos). + + (* branch (true ? false) (leaf : ([] ? [leaf])) *) + Definition ndTree `{ND} : Free Shape Pos (Tree Shape Pos Bool_) + := Branch Shape Pos + (True_ ? False_) + (Cons Shape Pos + (Leaf Shape Pos) + ( Nil Shape Pos + ? Cons Shape Pos + (Leaf Shape Pos) + (Nil Shape Pos))). + + (* (true -> (true ? false)) : ([] ? [(true ? false) -> false]) *) + Definition ndMap `{ND} : Free Shape Pos (Map Shape Pos Bool_ Bool_) + := Entry0 Shape Pos + True_ + (True_ ? False_) + ( Empty Shape Pos + ? Entry0 Shape Pos + (True_ ? False_) + False_ + (Empty Shape Pos)). + +End Data. + +Arguments ndList {_} {_} {_}. +Arguments ndFoo {_} {_} {_}. +Arguments ndTree {_} {_} {_}. +Arguments ndMap {_} {_} {_}. + +(* true : ([] ? [true ? false]) + --> [ [true], [true, true], [true, false] ] *) +Example nondeterministic_list : evalNDNF ndList + = [ myCons (pure true) (MyNil IdS IdP) + ; myCons (pure true) (MyCons IdS IdP (pure true) (MyNil IdS IdP)) + ; myCons (pure true) (MyCons IdS IdP (pure false) (MyNil IdS IdP)) + ]. +Proof. trivial. Qed. + +(* (foo baz) ? (foo (bar (foo baz))) + --> [ foo baz, foo (bar (foo baz)) ] *) +Example nondeterministic_foo : evalNDNF ndFoo + = [ foo (Bar0 IdS IdP (Foo0 IdS IdP (Baz IdS IdP))) + ; foo (Baz IdS IdP) + ]. +Proof. trivial. Qed. + +(* branch (true ? false) (leaf : ([] ? [leaf])) + --> [ branch true leaf, branch true [leaf, leaf] + , branch false leaf, branch false [leaf, leaf] ] *) +Example nondeterministic_tree : evalNDNF ndTree + = [ branch (pure true) (Cons IdS IdP (Leaf IdS IdP) (Nil IdS IdP)) + ; branch (pure true) (Cons IdS IdP (Leaf IdS IdP) + (Cons IdS IdP (Leaf IdS IdP) (Nil IdS IdP))) + ; branch (pure false) (Cons IdS IdP (Leaf IdS IdP) (Nil IdS IdP)) + ; branch (pure false) (Cons IdS IdP (Leaf IdS IdP) + (Cons IdS IdP (Leaf IdS IdP) (Nil IdS IdP))) + ]. +Proof. trivial. Qed. + +(* (true -> (true ? false)) : ([] ? [(true ? false) -> false]) + --> [ [true -> true] , [true -> true, true -> false] + , [true -> true, false -> false], [false -> true] + , [false -> true, true -> false], [false -> true, false -> false] ] *) +Example nondeterministic_map : evalNDNF ndMap + = [ entry (pure true) (pure true) (Empty IdS IdP) + ; entry (pure true) (pure true) + (Entry0 IdS IdP (pure true) (pure false) (Empty IdS IdP)) + ; entry (pure true) (pure true) + (Entry0 IdS IdP (pure false) (pure false) (Empty IdS IdP)) + ; entry (pure true) (pure false) (Empty IdS IdP) + ; entry (pure true) (pure false) + (Entry0 IdS IdP (pure true) (pure false) (Empty IdS IdP)) + ; entry (pure true) (pure false) + (Entry0 IdS IdP (pure false) (pure false) (Empty IdS IdP)) + ]. +Proof. trivial. Qed. From 26f73c3e6f497b07d127af7bf7a5bb26d3784a16 Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Sun, 30 Aug 2020 20:19:13 +0200 Subject: [PATCH 018/120] Run floskell #175 --- example/Proofs/Normalform.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/example/Proofs/Normalform.hs b/example/Proofs/Normalform.hs index 4d9e7987..ce43ce04 100644 --- a/example/Proofs/Normalform.hs +++ b/example/Proofs/Normalform.hs @@ -1,6 +1,5 @@ -- | This example defines some data types to check whether the [Normalform] -- instances are generated correctly. - module Proofs.Normalform where -- Basic recursive data type @@ -8,6 +7,7 @@ data MyList a = MyNil | MyCons a (MyList a) -- Mutually recursive data types data Foo a = Foo (Bar a) + data Bar a = Bar (Foo a) | Baz -- Data type with 'hidden' recursion From 49298a145b8070b6676e5b812ca21dc3257ea02c Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sat, 5 Sep 2020 09:52:13 +0200 Subject: [PATCH 019/120] Implement generalized smart constructors for Error effect #119 --- base/coq/Free/Instance/Error.v | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/base/coq/Free/Instance/Error.v b/base/coq/Free/Instance/Error.v index e562ce94..711f583a 100644 --- a/base/coq/Free/Instance/Error.v +++ b/base/coq/Free/Instance/Error.v @@ -11,9 +11,19 @@ Module Error. (* Type synonym and smart constructors for the error monad. *) Module Import Monad. Definition Error (E A : Type) := Free (Shape E) Pos A. - Definition NoError {E A : Type} (x : A) : Error E A := pure x. - Definition ThrowError {E A : Type} (msg : E) : Error E A := - impure msg (fun (p : Pos msg) => match p with end). + + (* The smart constructors embed the error effect in an effect stack *) + Definition NoError (Shape' : Type) (Pos' : Shape' -> Type) + {E A : Type} + `{Injectable (Shape E) Pos Shape' Pos'} + (x : A) : Free Shape' Pos' A := pure x. + + Definition ThrowError (Shape' : Type) (Pos' : Shape' -> Type) + {E A : Type} + `{Injectable (Shape E) Pos Shape' Pos'} + (msg : E) : Free Shape' Pos' A := + impure (injS msg) (fun p : Pos' (injS msg) => + (fun x : Void => match x with end) (injP p)). End Monad. (* Partial instance for the error monad. *) From 34c72b2aa0c5376abed957747a447a160076bf22 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sat, 5 Sep 2020 09:52:47 +0200 Subject: [PATCH 020/120] Implement generalized Partial instance for Error effect #119 --- base/coq/Free/Instance/Error.v | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/base/coq/Free/Instance/Error.v b/base/coq/Free/Instance/Error.v index 711f583a..13bd540e 100644 --- a/base/coq/Free/Instance/Error.v +++ b/base/coq/Free/Instance/Error.v @@ -27,9 +27,11 @@ Module Error. End Monad. (* Partial instance for the error monad. *) - Instance Partial : Partial (Shape string) Pos := { - undefined := fun {A : Type} => ThrowError "undefined"%string; - error := fun {A : Type} (msg : string) => ThrowError msg + Instance Partial (Shape' : Type) (Pos' : Shape' -> Type) + `{Injectable (Shape string) Pos Shape' Pos'} + : Partial Shape' Pos' := { + undefined := fun {A : Type} => ThrowError Shape' Pos' "undefined"%string; + error := fun {A : Type} (msg : string) => ThrowError Shape' Pos' msg }. End Error. From f89a4496f23e9b7e4c687a7df58d3a7012a9c433 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sat, 5 Sep 2020 10:04:17 +0200 Subject: [PATCH 021/120] Implement handler for Error effect #119 --- base/coq/Free/Instance/Error.v | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/base/coq/Free/Instance/Error.v b/base/coq/Free/Instance/Error.v index 13bd540e..dbdd1348 100644 --- a/base/coq/Free/Instance/Error.v +++ b/base/coq/Free/Instance/Error.v @@ -1,6 +1,7 @@ (** * Definition of the error monad in terms of the free monad. *) From Base Require Import Free. +From Base Require Import Free.Instance.Comb. From Base Require Import Free.Util.Void. Module Error. @@ -26,6 +27,26 @@ Module Error. (fun x : Void => match x with end) (injP p)). End Monad. + (* Handler for the error monad. *) + Module Import Handler. + (* Helper definitions and handler for the error effect. *) + Definition SError (Shape' : Type) (E : Type) := Comb.Shape (Shape E) Shape'. + Definition PError {Shape' : Type} (Pos' : Shape' -> Type) (E : Type) + := Comb.Pos (@Pos E) Pos'. + + (* The result is either a value of type A or an error message of type E. *) + Fixpoint runError {Shape' : Type} + {Pos' : Shape' -> Type} + {A E : Type} + (fm : Free (SError Shape' E) (PError Pos' E) A) + : Free Shape' Pos' (A + E) + := match fm with + | pure x => pure (inl x) + | impure (inl s) _ => pure (inr s) + | impure (inr s) pf => impure s (fun p => runError (pf p)) + end. + End Handler. + (* Partial instance for the error monad. *) Instance Partial (Shape' : Type) (Pos' : Shape' -> Type) `{Injectable (Shape string) Pos Shape' Pos'} @@ -35,7 +56,9 @@ Module Error. }. End Error. + (* The type and smart constructor should be visible to other modules but to use the shape or position function the identifier must be fully qualified, i.e. [Error.Partial]. *) +Export Error.Handler. Export Error.Monad. From cd6d82410aa025b1a904b421ed7ef9334ea13df7 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sat, 5 Sep 2020 10:27:40 +0200 Subject: [PATCH 022/120] Use string messages in Error handler #119 --- base/coq/Free/Instance/Error.v | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/base/coq/Free/Instance/Error.v b/base/coq/Free/Instance/Error.v index dbdd1348..7fdb4caa 100644 --- a/base/coq/Free/Instance/Error.v +++ b/base/coq/Free/Instance/Error.v @@ -29,17 +29,17 @@ Module Error. (* Handler for the error monad. *) Module Import Handler. - (* Helper definitions and handler for the error effect. *) - Definition SError (Shape' : Type) (E : Type) := Comb.Shape (Shape E) Shape'. - Definition PError {Shape' : Type} (Pos' : Shape' -> Type) (E : Type) - := Comb.Pos (@Pos E) Pos'. + (* Helper definitions and handler for the error effect with a string message. *) + Definition SError (Shape' : Type) := Comb.Shape (Shape string) Shape'. + Definition PError {Shape' : Type} (Pos' : Shape' -> Type) + := Comb.Pos (@Pos string) Pos'. (* The result is either a value of type A or an error message of type E. *) Fixpoint runError {Shape' : Type} {Pos' : Shape' -> Type} - {A E : Type} - (fm : Free (SError Shape' E) (PError Pos' E) A) - : Free Shape' Pos' (A + E) + {A : Type} + (fm : Free (SError Shape') (PError Pos') A) + : Free Shape' Pos' (A + string) := match fm with | pure x => pure (inl x) | impure (inl s) _ => pure (inr s) From ac737c8dd1e93e81984509dee001127fc3343d0a Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sat, 5 Sep 2020 11:02:17 +0200 Subject: [PATCH 023/120] Add Handler instances for Error #119 --- base/coq/Free/HandlerInstances.v | 130 ++++++++++++++++++++++++++++++- 1 file changed, 126 insertions(+), 4 deletions(-) diff --git a/base/coq/Free/HandlerInstances.v b/base/coq/Free/HandlerInstances.v index 6bbe603b..7a3f56b4 100644 --- a/base/coq/Free/HandlerInstances.v +++ b/base/coq/Free/HandlerInstances.v @@ -1,6 +1,7 @@ (** Instances for the Handler class. *) From Base Require Import Free. +From Base Require Import Free.Instance.Error. From Base Require Import Free.Instance.Identity. From Base Require Import Free.Instance.Maybe. From Base Require Import Free.Instance.ND. @@ -38,6 +39,27 @@ Instance HandlerMaybe (A B : Type) handle p := run (runMaybe (nf p)) }. +(* Error :+: Identity handler *) + +Definition SErrId := Comb.Shape (Error.Shape string) Identity.Shape. +Definition PErrId := Comb.Pos (@Error.Pos string) Identity.Pos. + +Instance HandlerError (A B : Type) + `{Normalform SErrId PErrId A B} : + Handler SErrId PErrId A (B + string) := { + handle p := run (runError (nf p)) +}. + +Definition pUndefined {Shape : Type} {Pos : Shape -> Type} (P : Partial Shape Pos) + := @undefined Shape Pos P (Bool Shape Pos). +Definition pError {Shape : Type} {Pos : Shape -> Type} (P : Partial Shape Pos) (msg : string) + := @error Shape Pos P (Bool Shape Pos) msg. + +Compute handle (pUndefined (Maybe.Partial _ _)). +Compute handle (pUndefined (Error.Partial _ _)). +Compute handle (pError (Maybe.Partial _ _) "Nope" ). +Compute handle (pError (Error.Partial _ _) "Nope" ). + (* ND :+: Identity handler *) Definition SNDId := Comb.Shape ND.Shape Identity.Shape. Definition PNDId := Comb.Pos ND.Pos Identity.Pos. @@ -72,6 +94,10 @@ Instance HandlerShare (A B : Type) (* Two effects *) +(* NOTE: There is no handler for an effect stack that contains both the Error and + Maybe effects. Both effects model partiality, but only one interpretation of + partiality is used at a time. *) + (* Share :+: ND :+: Identity handler *) Definition SShrND := Comb.Shape Share.Shape (Comb.Shape ND.Shape Identity.Shape). @@ -107,6 +133,9 @@ Instance HandlerMaybeShare (A B : Type) }. (* Maybe :+: ND :+: Identity handler *) +(* If an undefined value is evaluated in one non-deterministic branch of a program, + it should not affect the other branches. + Therefore, the maybe effect is handled before the non-determinism effect. *) Definition SMaybeND := Comb.Shape Maybe.Shape (Comb.Shape ND.Shape Identity.Shape). Definition PMaybeND := Comb.Pos Maybe.Pos (Comb.Pos ND.Pos Identity.Pos). @@ -118,6 +147,9 @@ Instance HandlerMaybeND (A B : Type) }. (* Maybe :+: Trace :+: Identity handler *) +(* In Haskell, when an undefined value is evaluated in a traced program, + the message log until that point is still displayed. + Therefore, the maybe effect is handled before the tracing effect. *) Definition SMaybeTrc := Comb.Shape Maybe.Shape (Comb.Shape Trace.Shape Identity.Shape). Definition PMaybeTrc := Comb.Pos Maybe.Pos (Comb.Pos Trace.Pos Identity.Pos). @@ -128,12 +160,46 @@ Instance HandlerMaybeTrc (A B : Type) handle p := collectMessages (run (runTracing (runMaybe (nf p)))) }. +(* Error :+: Share :+: Identity handler *) + +Definition SErrShr := Comb.Shape (Error.Shape string) (Comb.Shape Share.Shape Identity.Shape). +Definition PErrShr := Comb.Pos (@Error.Pos string) (Comb.Pos Share.Pos Identity.Pos). + +Instance HandlerErrorShare (A B : Type) + `{Normalform SErrShr PErrShr A B} : + Handler SErrShr PErrShr A (B + string) := { + handle p := run (runEmptySharing (0,0) (runError (nf p))) +}. + +(* Error :+: ND :+: Identity handler *) +(* If an error is thrown in one non-deterministic branch of a program, + it should not affect the other branches. + Therefore, the error effect is handled before the non-determinism effect. *) -(* -Instance HandlerTraceMaybe +Definition SErrND := Comb.Shape (Error.Shape string) (Comb.Shape ND.Shape Identity.Shape). +Definition PErrND := Comb.Pos (@Error.Pos string) (Comb.Pos ND.Pos Identity.Pos). -Instance Handler NDMaybe. -*) +Instance HandlerErrorND (A B : Type) + `{Normalform SErrND PErrND A B} : + Handler SErrND PErrND A (list (B + string)) := { + handle p := collectVals (run (runChoice (runError (nf p)))) +}. + +(* Error :+: Trace :+: Identity handler *) +(* In Haskell, when an error is thrown in a traced program, the message log until that point + is displayed alongside the error message. + Therefore, the error effect is handled before the tracing effect. *) + +Definition SErrorTrc := Comb.Shape (Error.Shape string) (Comb.Shape Trace.Shape Identity.Shape). +Definition PErrorTrc := Comb.Pos (@Error.Pos string) (Comb.Pos Trace.Pos Identity.Pos). + +Instance HandlerErrorTrc (A B : Type) + `{Normalform SErrorTrc PErrorTrc A B} : + Handler SErrorTrc PErrorTrc A ((B + string) * list string) := { + handle p := collectMessages (run (runTracing (runError (nf p)))) +}. + +Compute handle (trace "Hey!" (trace "Ho!" (error "Nope"))). (* Trace :+: ND :+: Identity handler *) @@ -210,3 +276,59 @@ Instance HandlerMaybeTrcND (A B : Type) (@collectVals (option B * list (option Sharing.ID * string)) (run (runChoice (runTracing (runMaybe (nf p)))))) }. + +(* Error :+: Share :+: ND :+: Identity handler *) + +Definition SErrShrND := + Comb.Shape (Error.Shape string) + (Comb.Shape Share.Shape + (Comb.Shape ND.Shape Identity.Shape)). + +Definition PErrShrND := + Comb.Pos (@Error.Pos string) + (Comb.Pos Share.Pos + (Comb.Pos ND.Pos Identity.Pos)). + +Instance HandlerErrorSharingND (A B : Type) + `{Normalform SErrShrND PErrShrND A B} : + Handler SErrShrND PErrShrND A (list (B + string)) := { + handle p := collectVals (run (runChoice (runNDSharing (0,0) (runError (nf p))))) +}. + +(* Error :+: Share :+: Trace :+: Identity handler *) + +Definition SErrShrTrc := + Comb.Shape (Error.Shape string) + (Comb.Shape Share.Shape + (Comb.Shape Trace.Shape Identity.Shape)). + +Definition PErrShrTrc := + Comb.Pos (@Error.Pos string) + (Comb.Pos Share.Pos + (Comb.Pos Trace.Pos Identity.Pos)). + +Instance HandlerErrorShareTrace (A B : Type) + `{Normalform SErrShrTrc PErrShrTrc A B} : + Handler SErrShrTrc PErrShrTrc A ((B + string) * list string) := { + handle p := collectMessages (run (runTracing (runTraceSharing (0,0) (runError (nf p))))) +}. + +(* Error :+: Trace :+: ND :+: Identity handler *) + +Definition SErrTrcND := + Comb.Shape (Error.Shape string) + (Comb.Shape Trace.Shape + (Comb.Shape ND.Shape Identity.Shape)). + +Definition PErrTrcND := + Comb.Pos (@Error.Pos string) + (Comb.Pos Trace.Pos + (Comb.Pos ND.Pos Identity.Pos)). + +Instance HandlerErrorTrcND (A B : Type) + `{Normalform SErrTrcND PErrTrcND A B} : + Handler SErrTrcND PErrTrcND A (list ((B + string) * list string)) := { + handle p := map (@collectMessages (B + string)) + (@collectVals ((B + string) * list (option Sharing.ID * string)) + (run (runChoice (runTracing (runError (nf p)))))) +}. From 2b1aa90d2d2a25567d0cf0d761e5365196946032 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Thu, 10 Sep 2020 12:18:26 +0200 Subject: [PATCH 024/120] Add documentation and refactor code #150 --- .github/workflows/ci-pipeline.yml | 4 +- README.md | 2 +- base/coq/Free/Class/Normalform.v | 6 +- base/coq/Free/Class/ShareableArgs.v | 13 +- base/coq/Free/Malias.v | 7 +- .../Free/Verification/NormalizationTests.v | 283 +++++++++--------- .../Free/Verification/SharingHandlerTests.v | 262 +++++++++++----- base/coq/Prelude/Bool.v | 2 +- base/coq/Prelude/List.v | 44 +-- base/coq/Prelude/Pair.v | 28 +- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 172 +++++++++-- tool/full-test.sh | 2 +- 12 files changed, 520 insertions(+), 305 deletions(-) diff --git a/.github/workflows/ci-pipeline.yml b/.github/workflows/ci-pipeline.yml index 5e6cf22e..2300bdd3 100644 --- a/.github/workflows/ci-pipeline.yml +++ b/.github/workflows/ci-pipeline.yml @@ -350,7 +350,7 @@ jobs: container: coqorg/coq:${{ matrix.coq }} strategy: matrix: - coq: ["8.8", "8.9", "8.10", "8.11"] + coq: ["8.10", "8.11", "8.12"] if: github.event_name != 'pull_request' || !github.event.pull_request.draft steps: - name: Fix file permissions @@ -459,7 +459,7 @@ jobs: container: coqorg/coq:${{ matrix.coq }} strategy: matrix: - coq: ["8.8", "8.9", "8.10", "8.11"] + coq: ["8.10", "8.11", "8.12"] steps: - name: Fix file permissions run: sudo chown -R coq:coq . diff --git a/README.md b/README.md index 2182333d..9d68df45 100644 --- a/README.md +++ b/README.md @@ -163,7 +163,7 @@ The compiler has been tested with the following software versions on a Debian ba - [GHC][software/ghc], version 8.6.5 - [Cabal][software/cabal], version 3.2.0.0 - - [Coq][software/coq], versions 8.8 through 8.11 + - [Coq][software/coq], versions 8.10 through 8.12 - [Agda][software/agda], versions 2.6.1 - [Agda Standard Library][software/agda-stdlib], version 1.3 diff --git a/base/coq/Free/Class/Normalform.v b/base/coq/Free/Class/Normalform.v index 178a94b8..9c51673b 100644 --- a/base/coq/Free/Class/Normalform.v +++ b/base/coq/Free/Class/Normalform.v @@ -29,4 +29,8 @@ Lemma nfPure {Shape : Type} {Pos : Shape -> Type} {A B : Type} nf (pure x) = nf' x. Proof. trivial. Qed. - +(* Normalform instance for functions. + Effects inside of functions are not pulled to the root. *) +Instance NormalformFunc (Shape : Type) (Pos : Shape -> Type) (A B : Type) + : Normalform Shape Pos (A -> B) (A -> B) := + { nf' := pure }. \ No newline at end of file diff --git a/base/coq/Free/Class/ShareableArgs.v b/base/coq/Free/Class/ShareableArgs.v index f3338939..60458f42 100644 --- a/base/coq/Free/Class/ShareableArgs.v +++ b/base/coq/Free/Class/ShareableArgs.v @@ -5,10 +5,9 @@ Class ShareableArgs (Shape : Type) (Pos : Shape -> Type) { shareArgs : A -> Free Shape Pos A }. -(* -Instance ShareableArgsDummy (Shape : Type) (Pos : Shape -> Type) - (A : Type) - : ShareableArgs Shape Pos A | 5 := { - shareArgs := pure - }. -*) \ No newline at end of file + +(* ShareableArgs instance for functions. + Effects inside of functions are not shared. *) +Instance ShareableArgsFunc (Shape : Type) (Pos : Shape -> Type) (A B : Type) + : ShareableArgs Shape Pos (A -> B) := + { shareArgs := pure }. \ No newline at end of file diff --git a/base/coq/Free/Malias.v b/base/coq/Free/Malias.v index 3fd0a608..5e969a4b 100644 --- a/base/coq/Free/Malias.v +++ b/base/coq/Free/Malias.v @@ -28,7 +28,7 @@ Notation "'EndShare''" := (EndShare Shape Pos). Definition cbneed {A : Type} `{Injectable Share.Shape Share.Pos Shape Pos} - `{ShareableArgs Shape Pos A} + (shrArgs : A -> Free Shape Pos A) (p : Free Shape Pos A) : Free Shape Pos (Free Shape Pos A) := Get' >>= fun '(i,j) => @@ -36,18 +36,17 @@ Definition cbneed {A : Type} pure (BeginShare' (i,j) >> Put' (i,j+1) >> p >>= fun x => - shareArgs x >>= fun x' => + shrArgs x >>= fun x' => Put' (i+1,j) >> EndShare' (i,j) >> pure x'). End SecCbneed. - (* Shareable instances. *) Instance Cbneed (Shape : Type) (Pos : Shape -> Type) `{I : Injectable Share.Shape Share.Pos Shape Pos} : Shareable Shape Pos | 1 := { - share A S p := @cbneed Shape Pos A I S p + share A S p := @cbneed Shape Pos A I (@shareArgs Shape Pos A S) p }. (* The Share effect is not actually needed, but we need to diff --git a/base/coq/Free/Verification/NormalizationTests.v b/base/coq/Free/Verification/NormalizationTests.v index 716fdcf3..caab6b0b 100644 --- a/base/coq/Free/Verification/NormalizationTests.v +++ b/base/coq/Free/Verification/NormalizationTests.v @@ -13,8 +13,8 @@ Import List.ListNotations. (* Shortcuts to handle a program. *) -(* Shortcut to evaluate a non-deterministic program to a result list. - list without normalization. *) +(* Shortcut to evaluate a non-deterministic program to a result list + without normalization. *) Definition evalND {A : Type} (p : Free _ _ A) := @collectVals A (run (runChoice p)). @@ -64,109 +64,110 @@ Arguments MaybePartial {_} {_} {_}. (* Effectful lists *) Section SecData. -Variable Shape : Type. -Variable Pos : Shape -> Type. -Notation "'FreeBoolList'" := (Free Shape Pos (List Shape Pos (Bool Shape Pos))). -Notation "'ND'" := (Injectable ND.Shape ND.Pos Shape Pos). -Notation "'Trace'" := (Traceable Shape Pos). -Notation "'Partial'" := (Partial Shape Pos). -Notation "'FreeBoolListList'" := (Free Shape Pos (List Shape Pos (List Shape Pos (Bool Shape Pos)))). - -(* Lists with effects at the root. *) - -(* [] ? [true,false] *) -Definition rootNDList `{ND} : FreeBoolList -:= Choice Shape Pos - (Nil Shape Pos) - (Cons Shape Pos - (pure true) - (Cons Shape Pos - (pure false) - (Nil Shape Pos) - ) - ). - -(* trace "root effect" [true, false] *) -Definition rootTracedList `{Trace} : FreeBoolList -:= trace "root effect" - (Cons Shape Pos (pure true) - (Cons Shape Pos - (pure false) - (Nil Shape Pos))). - -(* Lists with an effectful element. *) - -(* [true,true ? false] *) -Definition coinList `{ND} : FreeBoolList - := Cons Shape Pos - (pure true) - (Cons Shape Pos (Choice Shape Pos (pure true) (pure false)) - (Nil Shape Pos)). - -(* [true, trace "component effect" false] *) -Definition traceList `{Trace} : FreeBoolList - := Cons Shape Pos (pure true) - (Cons Shape Pos (trace "component effect" (pure false)) - (Nil Shape Pos)). - -(* [true, undefined] *) -Definition partialList `(Partial) : FreeBoolList - := Cons Shape Pos (True_ Shape Pos) - (Cons Shape Pos undefined (Nil Shape Pos)). - -(* [true, false ? undefined] *) -Definition partialCoinList `{ND} `(Partial) : FreeBoolList - := Cons Shape Pos (True_ Shape Pos) - (Cons Shape Pos (Choice Shape Pos (False_ Shape Pos) - undefined) - (Nil Shape Pos)). - -(* List with an effect at the root and an effectful element. *) - -(* trace "root effect" [true, trace "component effect" false] *) -Definition tracedTraceList `{Trace} : FreeBoolList - := trace "root effect" - (Cons Shape Pos (pure true) - (Cons Shape Pos (trace "component effect" (pure false)) - (Nil Shape Pos))). - -(* [] ? [true,true ? false] *) -Definition NDCoinList `{ND} : FreeBoolList - := Choice Shape Pos (Nil Shape Pos) - (Cons Shape Pos - (pure true) - (Cons Shape Pos - (Choice Shape Pos (pure true) (pure false)) - (Nil Shape Pos))). - -(* Deep effectful components *) - -(* [[true, true ? false]] *) -Definition deepCoinList `{ND} : FreeBoolListList - := Cons Shape Pos - (Cons Shape Pos + Variable Shape : Type. + Variable Pos : Shape -> Type. + + Notation "'FreeBoolList'" := (Free Shape Pos (List Shape Pos (Bool Shape Pos))). + Notation "'ND'" := (Injectable ND.Shape ND.Pos Shape Pos). + Notation "'Trace'" := (Traceable Shape Pos). + Notation "'Partial'" := (Partial Shape Pos). + Notation "'FreeBoolListList'" := (Free Shape Pos (List Shape Pos (List Shape Pos (Bool Shape Pos)))). + + (* Lists with effects at the root. *) + + (* [] ? [true,false] *) + Definition rootNDList `{ND} : FreeBoolList + := Choice Shape Pos + (Nil Shape Pos) + (Cons Shape Pos + (pure true) + (Cons Shape Pos + (pure false) + (Nil Shape Pos) + ) + ). + + (* trace "root effect" [true, false] *) + Definition rootTracedList `{Trace} : FreeBoolList + := trace "root effect" + (Cons Shape Pos (pure true) + (Cons Shape Pos + (pure false) + (Nil Shape Pos))). + + (* Lists with an effectful element. *) + + (* [true,true ? false] *) + Definition coinList `{ND} : FreeBoolList + := Cons Shape Pos (pure true) (Cons Shape Pos (Choice Shape Pos (pure true) (pure false)) - (Nil Shape Pos))) - (Nil Shape Pos). - -(* [[true, trace "component effect" false]] *) -Definition deepTraceList `{Trace} : FreeBoolListList - := Cons Shape Pos - (Cons Shape Pos + (Nil Shape Pos)). + + (* [true, trace "component effect" false] *) + Definition traceList `{Trace} : FreeBoolList + := Cons Shape Pos (pure true) + (Cons Shape Pos (trace "component effect" (pure false)) + (Nil Shape Pos)). + + (* [true, undefined] *) + Definition partialList `(Partial) : FreeBoolList + := Cons Shape Pos (True_ Shape Pos) + (Cons Shape Pos undefined (Nil Shape Pos)). + + (* [true, false ? undefined] *) + Definition partialCoinList `{ND} `(Partial) : FreeBoolList + := Cons Shape Pos (True_ Shape Pos) + (Cons Shape Pos (Choice Shape Pos (False_ Shape Pos) + undefined) + (Nil Shape Pos)). + + (* List with an effect at the root and an effectful element. *) + + (* trace "root effect" [true, trace "component effect" false] *) + Definition tracedTraceList `{Trace} : FreeBoolList + := trace "root effect" + (Cons Shape Pos (pure true) + (Cons Shape Pos (trace "component effect" (pure false)) + (Nil Shape Pos))). + + (* [] ? [true,true ? false] *) + Definition NDCoinList `{ND} : FreeBoolList + := Choice Shape Pos (Nil Shape Pos) + (Cons Shape Pos + (pure true) + (Cons Shape Pos + (Choice Shape Pos (pure true) (pure false)) + (Nil Shape Pos))). + + (* Deep effectful components *) + + (* [[true, true ? false]] *) + Definition deepCoinList `{ND} : FreeBoolListList + := Cons Shape Pos + (Cons Shape Pos (pure true) - (Cons Shape Pos (trace "component effect" (pure false)) + (Cons Shape Pos (Choice Shape Pos (pure true) (pure false)) (Nil Shape Pos))) - (Nil Shape Pos). - -(* A function that is the same as head for non-empty lists. - Empty lists yield false. *) -Definition headOrFalse (fl : FreeBoolList) - : Free Shape Pos bool - := fl >>= fun l => match l with - | List.nil => pure false - | List.cons fb _ => fb - end. + (Nil Shape Pos). + + (* [[true, trace "component effect" false]] *) + Definition deepTraceList `{Trace} : FreeBoolListList + := Cons Shape Pos + (Cons Shape Pos + (pure true) + (Cons Shape Pos (trace "component effect" (pure false)) + (Nil Shape Pos))) + (Nil Shape Pos). + + (* A function that is the same as head for non-empty lists. + Empty lists yield false. *) + Definition headOrFalse (fl : FreeBoolList) + : Free Shape Pos bool + := fl >>= fun l => match l with + | List.nil => pure false + | List.cons fb _ => fb + end. End SecData. @@ -186,45 +187,45 @@ Arguments headOrFalse {_} {_} fl. (* Section for auxiliary properties *) Section SecProps. -Variable Shape1 : Type. -Variable Shape2 : Type. -Variable Pos1 : Shape1 -> Type. -Variable Pos2 : Shape2 -> Type. - -Notation "'BoolList1'" := (List Shape1 Pos1 (Bool Shape1 Pos1)). -Notation "'BoolList2'" := (List Shape2 Pos2 (Bool Shape2 Pos2)). - -(* A property that is fulfilled if two lists of Bools are - effect-free and contain the same values. *) -Fixpoint pure_equalB (l1 : BoolList1) (l2 : BoolList2) : Prop - := match l1, l2 with - | List.nil, List.nil => True - | (List.cons fx fxs), (List.cons fy fys) => match fx, fxs, fy, fys with - | (pure x), (pure xs), (pure y), (pure ys) => - x = y /\ pure_equalB xs ys - | _, _, _, _ => False - end - | _, _ => False - end. - -(* A property that is fulfilled if two traced (handled) lists are effect-free and - contain the same values. *) -Definition eqTracedList (e1 : BoolList1 * list string) - (e2 : BoolList2 * list string) - := match e1 with - | (l1,log1) => match e2 with - | (l2, log2) => log1 = log2 /\ pure_equalB l1 l2 - end - end. - -(* A property that is fulfilled if two non-deterministic (handled) lists are - effect-free and contain the same values. *) -Fixpoint eqNDList (e1 : list BoolList1) (e2 : list BoolList2) - := match e1, e2 with - | nil, nil => True - | (cons l1 l1s), (cons l2 l2s) => pure_equalB l1 l2 /\ eqNDList l1s l2s - | _, _ => False - end. + Variable Shape1 : Type. + Variable Shape2 : Type. + Variable Pos1 : Shape1 -> Type. + Variable Pos2 : Shape2 -> Type. + + Notation "'BoolList1'" := (List Shape1 Pos1 (Bool Shape1 Pos1)). + Notation "'BoolList2'" := (List Shape2 Pos2 (Bool Shape2 Pos2)). + + (* A property that is fulfilled if two lists of Bools are + effect-free and contain the same values. *) + Fixpoint pure_equalB (l1 : BoolList1) (l2 : BoolList2) : Prop + := match l1, l2 with + | List.nil, List.nil => True + | (List.cons fx fxs), (List.cons fy fys) => match fx, fxs, fy, fys with + | (pure x), (pure xs), (pure y), (pure ys) => + x = y /\ pure_equalB xs ys + | _, _, _, _ => False + end + | _, _ => False + end. + + (* A property that is fulfilled if two traced (handled) lists are effect-free and + contain the same values. *) + Definition eqTracedList (e1 : BoolList1 * list string) + (e2 : BoolList2 * list string) + := match e1 with + | (l1,log1) => match e2 with + | (l2, log2) => log1 = log2 /\ pure_equalB l1 l2 + end + end. + + (* A property that is fulfilled if two non-deterministic (handled) lists are + effect-free and contain the same values. *) + Fixpoint eqNDList (e1 : list BoolList1) (e2 : list BoolList2) + := match e1, e2 with + | nil, nil => True + | (cons l1 l1s), (cons l2 l2s) => pure_equalB l1 l2 /\ eqNDList l1s l2s + | _, _ => False + end. End SecProps. @@ -390,4 +391,4 @@ Example deepEffectND : evalNDNF deepCoinList (Nil IdS IdP)))) (Nil IdS IdP) ]. -Proof. constructor. Qed. \ No newline at end of file +Proof. constructor. Qed. diff --git a/base/coq/Free/Verification/SharingHandlerTests.v b/base/coq/Free/Verification/SharingHandlerTests.v index 7f9aec6c..4198f8f1 100644 --- a/base/coq/Free/Verification/SharingHandlerTests.v +++ b/base/coq/Free/Verification/SharingHandlerTests.v @@ -32,7 +32,7 @@ Definition evalTracing {A : Type} p Definition evalNDM {A : Type} p := @collectVals (option A) (run (runChoice (runNDSharing (0,0) (runMaybe p)))). -(* Shortcut to evaluate a traced partial pro gram to a result and a list +(* Shortcut to evaluate a traced partial program to a result and a list of logged messages. *) Definition evalTraceM {A : Type} p := @collectMessages (option A) @@ -40,37 +40,68 @@ Definition evalTraceM {A : Type} p Section SecData. -Variable Shape : Type. -Variable Pos : Shape -> Type. + Variable Shape : Type. + Variable Pos : Shape -> Type. -Notation "'ND'" := (Injectable ND.Shape ND.Pos Shape Pos). -Notation "'Trace'" := (Traceable Shape Pos). -Notation "'Maybe'" := (Injectable Maybe.Shape Maybe.Pos Shape Pos). + Notation "'ND'" := (Injectable ND.Shape ND.Pos Shape Pos). + Notation "'Trace'" := (Traceable Shape Pos). + Notation "'Maybe'" := (Injectable Maybe.Shape Maybe.Pos Shape Pos). -(* Non-deterministic integer. *) -Definition coin `{ND} -:= Choice Shape Pos (pure 0%Z) (pure 1%Z). + (* Non-deterministic integer. *) + Definition coin `{ND} + := Choice Shape Pos (pure 0%Z) (pure 1%Z). -(* Non-deterministic boolean value. *) -Definition coinB `{ND} := Choice Shape Pos (True_ _ _) (False_ _ _). + (* Non-deterministic boolean value. *) + Definition coinB `{ND} := Choice Shape Pos (True_ _ _) (False_ _ _). -(* Non-deterministic partial integer. *) -Definition coinM `{ND} `{Maybe} -:= Choice Shape Pos (Nothing_inj _ _) (Just_inj _ _ 1%Z). + (* Non-deterministic partial integer. *) + Definition coinM `{ND} `{Maybe} + := Choice Shape Pos (Nothing_inj _ _) (Just_inj _ _ 1%Z). -(* Traced integer. *) -Definition traceOne `{Trace} := trace "One" (pure 1%Z). + (* (0 ? 1, 2 ? 3) *) + Definition coinPair `{ND} + : Free Shape Pos (Pair Shape Pos (Integer Shape Pos) (Integer Shape Pos)) + := Pair_ Shape Pos (Choice Shape Pos (pure 0%Z) (pure 1%Z)) + (Choice Shape Pos (pure 2%Z) (pure 3%Z)). -(* Traced boolean values. *) -Definition traceTrue `{Trace} := trace "True" (True_ _ _). + (* [0 ? 1, 2 ? 3] *) + Definition coinList `{ND} + : Free Shape Pos (List Shape Pos (Integer Shape Pos)) + := List.Cons Shape Pos + (Choice Shape Pos (pure 0%Z) (pure 1%Z)) + (List.Cons Shape Pos + (Choice Shape Pos (pure 2%Z) (pure 3%Z)) + (List.Nil Shape Pos)). -Definition traceFalse `{Trace} := trace "False" (False_ _ _). -(* Traced Maybe values *) -Definition traceNothing `{Trace} `{Maybe} -:= trace "Nothing" (@Nothing_inj (Integer Shape Pos) _ _ _). + (* Traced integer. *) + Definition traceOne `{Trace} := trace "One" (pure 1%Z). -Definition traceJust `{Trace} `{Maybe} := trace "Just 1" (Just_inj _ _ 1%Z). + (* Traced boolean values. *) + Definition traceTrue `{Trace} := trace "True" (True_ _ _). + + Definition traceFalse `{Trace} := trace "False" (False_ _ _). + + (* Traced Maybe values *) + Definition traceNothing `{Trace} `{Maybe} + := trace "Nothing" (@Nothing_inj (Integer Shape Pos) _ _ _). + + Definition traceJust `{Trace} `{Maybe} := trace "Just 1" (Just_inj _ _ 1%Z). + + (* (trace "0" 0, trace "1" 1) *) + Definition tracePair `{Trace} + : Free Shape Pos (Pair Shape Pos (Integer Shape Pos) (Integer Shape Pos)) + := Pair_ Shape Pos (trace "0" (pure 0%Z)) + (trace "1" (pure 1%Z) ). + + (* [trace "0" 0, trace "1" 1] *) + Definition traceList `{Trace} + : Free Shape Pos (List Shape Pos (Integer Shape Pos)) + := List.Cons Shape Pos + (trace "0" (pure 0%Z)) + (List.Cons Shape Pos + (trace "1" (pure 2%Z)) + (List.Nil Shape Pos)). End SecData. @@ -78,72 +109,98 @@ End SecData. Arguments coin {_} {_} {_}. Arguments coinB {_} {_} {_}. Arguments coinM {_} {_} {_} {_}. +Arguments coinPair {_} {_} {_}. +Arguments coinList {_} {_} {_}. Arguments traceOne {_} {_} {_}. Arguments traceTrue {_} {_} {_}. Arguments traceFalse {_} {_} {_}. Arguments traceNothing {_} {_} {_} {_}. Arguments traceJust {_} {_} {_} {_}. +Arguments tracePair {_} {_} {_}. +Arguments traceList {_} {_} {_}. (* Test functions *) Section SecFunctions. -Set Implicit Arguments. -Variable Shape : Type. -Variable Pos : Shape -> Type. -Variable A : Type. -Notation "'FreeA'" := (Free Shape Pos A). -Notation "'ShareArgs'" := (ShareableArgs Shape Pos A). - -(* This function applies the given binary function to the given argument - twice and does not share the argument. *) -Definition double (f : FreeA -> FreeA -> FreeA ) (fx : FreeA) : FreeA -:= f fx fx. - -(* Simple sharing: - let sx = fx in f sx sx *) -Definition doubleShared `(Shareable Shape Pos) `{ShareArgs} + Set Implicit Arguments. + Variable Shape : Type. + Variable Pos : Shape -> Type. + Variable A : Type. + Notation "'FreeA'" := (Free Shape Pos A). + Notation "'ShareArgs'" := (ShareableArgs Shape Pos A). + Notation "'Share'" := (Injectable Share.Shape Share.Pos Shape Pos). + Notation "'Maybe'" := (Injectable Maybe.Shape Maybe.Pos Shape Pos). + + (* This function applies the given binary function to the given argument + twice and does not share the argument. *) + Definition double (f : FreeA -> FreeA -> FreeA ) (fx : FreeA) : FreeA + := f fx fx. + + (* Simple sharing: + let sx = fx in f sx sx *) + Definition doubleShared `{I : Share} `{SA : ShareArgs} (S : Shareable Shape Pos) (f : FreeA -> FreeA -> FreeA) (fx : FreeA) - : FreeA -:= share fx >>= fun sx => f sx sx. - -(* Nested sharing: - let sx = fx - sy = f sx sx - in f sy sy *) -Definition doubleSharedNested `(Shareable Shape Pos) `{ShareArgs} + : FreeA + := @share Shape Pos I S A SA fx >>= fun sx => f sx sx. + + (* Nested sharing: + let sx = fx + sy = f sx sx + in f sy sy *) + Definition doubleSharedNested `{I : Share} `{SA : ShareArgs} (S : Shareable Shape Pos) + (f : FreeA -> FreeA -> FreeA) + (fx : FreeA) + : FreeA + := @share Shape Pos I S A SA (@share Shape Pos I S A SA fx >>= fun sx => f sx sx) >>= fun sy => + f sy sy. + + (* let sx = fx + sy = f sx sx + sz = fy + in f sy sz *) + Definition doubleSharedClash `{I : Share} `{SA : ShareArgs} (S : Shareable Shape Pos) (f : FreeA -> FreeA -> FreeA) - (fx : FreeA) - : FreeA -:= share (share fx >>= fun sx => f sx sx) >>= fun sy => - f sy sy. - -(* let sx = fx - sy = f sx sx - sz = fy - in f sy sz *) -Definition doubleSharedClash `(Shareable Shape Pos) `{ShareArgs} + (fx : FreeA) (fy : FreeA) + : FreeA + := @share Shape Pos I S A SA (@share Shape Pos I S A SA fx >>= fun sx => f sx sx) >>= fun sy => + @share Shape Pos I S A SA fy >>= fun sz => f sy sz. + + (* + let sx = val + sy = f sx fx + sz = f sy fy + in f sx (f sy (f sz val)) + *) + Definition doubleSharedRec `{I : Share} `{SA : ShareArgs} (S : Shareable Shape Pos) (f : FreeA -> FreeA -> FreeA) - (fx : FreeA) (fy : FreeA) - : FreeA -:= share (share fx >>= fun sx => f sx sx) >>= fun sy => - share fy >>= fun sz => f sy sz. + (fx : FreeA) (fy : FreeA) + (val : A) + : FreeA + := @share Shape Pos I S A SA (pure val) >>= fun sx => + f sx (@share Shape Pos I S A SA (f sx fx) >>= fun sy => + f sy (@share Shape Pos I S A SA (f sy fy) >>= fun sz => + f sz (pure val))). + + (* Deep sharing. *) + Definition doubleDeepSharedPair `{I : Share} `{SA : ShareArgs} (S : Shareable Shape Pos) + (f : FreeA -> FreeA -> FreeA) + (fx : Free Shape Pos (Pair Shape Pos A A)) + : FreeA + := @share Shape Pos I S (Pair Shape Pos A A) _ fx >>= fun sx => f (fstPair Shape Pos sx) (fstPair Shape Pos sx). -(* -let sx = val - sy = f sx fx - sz = f sy fy -in f sx (f (sy (f sz val))) -*) -Definition doubleSharedRec `(Shareable Shape Pos) `{ShareArgs} - (f : FreeA -> FreeA -> FreeA) - (fx : FreeA) (fy : FreeA) - (val : A) - : FreeA -:= share (pure val) >>= fun sx => - f sx (share (f sx fx) >>= fun sy => - f sy (share (f sy fy) >>= fun sz => - f sz (pure val))). + Definition headList (P : Partial Shape Pos) (fl : Free Shape Pos (List Shape Pos A)) : FreeA + := fl >>= fun l => match l with + | List.cons fx _ => fx + | List.nil => @undefined Shape Pos P A + end. + + Definition doubleDeepSharedList `{I : Share} `{SA : ShareArgs} (P : Partial Shape Pos) (S : Shareable Shape Pos) + (f : FreeA -> FreeA -> FreeA) + (fl : Free Shape Pos (List Shape Pos A)) + : FreeA + := @share Shape Pos I S (List Shape Pos A) _ fl >>= fun sx => + f (headList P sx) (headList P sx). End SecFunctions. @@ -571,4 +628,57 @@ Example exOrRecFalseTracing : evalTracing (nf (doubleSharedRec Cbneed_ orBool_ traceFalse traceFalse false)) = (false,["False"%string;"False"%string]). -Proof. constructor. Qed. \ No newline at end of file +Proof. constructor. Qed. + + +(* ----------------------- Test cases for deep sharing --------------------- *) + +(* +let sx = (0 ? 1, 2 ? 3) +in fst sx + fst sx + += (0 + 0) ? (1 + 1) += 0 ? 2 +*) +Example exAddDeepPairND + : evalND (nf (doubleDeepSharedPair Cbneed_ addInteger_ coinPair)) + = [0%Z;2%Z]. +Proof. constructor. Qed. + +(* let sx = [0 ? 1, 2 ? 3] +in head sx + head sx += (0 + 0) ? (1 + 1) += 0 ? 2 +*) +Example exAddDeepListND + : evalND (nf + (doubleDeepSharedList (PartialLifted ND.Shape ND.Pos _ _ ND.Partial) Cbneed_ addInteger_ coinList)) + = [0%Z;2%Z]. +Proof. constructor. Qed. + +(* +let sx = (trace "0" 0, trace "1" 1) +in fst sx + fst sx +=> The pair is shared, so the effects inside the pair should be shared as + well. Since we take the first element twice, the second tracing message ("1") + should not be logged and the first should be shared and thus logged once. +*) +Example exAddDeepPairTrace + : evalTracing (nf (doubleDeepSharedPair Cbneed_ addInteger_ tracePair)) + = (0%Z, ["0"%string]). +Proof. constructor. Qed. + +(* +let sx = [trace "0" 0, trace "1" 1] +in head sx + head sx +=> The list is shared, so the effects inside the list should be shared as + well. Since we take the first element twice, the second tracing message ("1") + should not be logged and the first should be shared and thus logged once. + Because head is partial and we use the Maybe instance of Partial, the result + should be Some 0 instead of simply 0. +*) +Example exAddDeepListTrace + : evalTraceM (nf + (doubleDeepSharedList (PartialLifted Maybe.Shape Maybe.Pos _ _ Maybe.Partial) Cbneed_ addInteger_ traceList)) + = (Some 0%Z, ["0"%string]). +Proof. constructor. Qed. diff --git a/base/coq/Prelude/Bool.v b/base/coq/Prelude/Bool.v index f697f0c9..98416186 100644 --- a/base/coq/Prelude/Bool.v +++ b/base/coq/Prelude/Bool.v @@ -39,4 +39,4 @@ Instance ShareableArgsBool (Shape : Type) (Pos : Shape -> Type) : ShareableArgs Shape Pos (Bool Shape Pos) := { shareArgs := pure - }. + }. \ No newline at end of file diff --git a/base/coq/Prelude/List.v b/base/coq/Prelude/List.v index 0aa39d08..c099eaa2 100644 --- a/base/coq/Prelude/List.v +++ b/base/coq/Prelude/List.v @@ -56,41 +56,29 @@ Section SecListNF. End SecListNF. -Section SecListShrArgs. - Variable Shape : Type. - Variable Pos : Shape -> Type. - Variable A : Type. +Section SecListShrArgs. - Fixpoint shareArgsList `{ShareableArgs Shape Pos A} - `{Injectable Share.Shape Share.Pos Shape Pos} - (xs : List Shape Pos A) - : Free Shape Pos (List Shape Pos A) - := - let shr fp := Get Shape Pos >>= fun '(i,j) => - Put Shape Pos (i + 1, j) >> - pure (BeginShare Shape Pos (i,j) >> - Put Shape Pos (i, j + 1) >> - fp >>= fun x => - shareArgsList x >>= fun x' => - Put Shape Pos (i + 1, j) >> - EndShare Shape Pos (i,j) >> - pure x') - in - match xs with - | nil => pure nil - | cons fy fys => - shr fys >>= fun sys => - cbneed Shape Pos fy >>= fun sy => - pure (cons sy sys) +Variable Shape : Type. +Variable Pos : Shape -> Type. +Variable A : Type. + +Fixpoint shareArgsList `{SA : ShareableArgs Shape Pos A} + `{Injectable Share.Shape Share.Pos Shape Pos} + (xs : List Shape Pos A) + {struct xs} + : Free Shape Pos (List Shape Pos A) + := match xs with + | nil => pure nil + | cons fy fys => cbneed Shape Pos (@shareArgs Shape Pos A SA) fy >>= fun sy => + cbneed Shape Pos shareArgsList fys >>= fun sys => + pure (cons sy sys) end. Global Instance ShareableArgsList `{Injectable Share.Shape Share.Pos Shape Pos} `{ShareableArgs Shape Pos A} : ShareableArgs Shape Pos (List Shape Pos A) - := { - shareArgs := shareArgsList - }. + := { shareArgs := shareArgsList }. End SecListShrArgs. diff --git a/base/coq/Prelude/Pair.v b/base/coq/Prelude/Pair.v index 37b8a254..7b3e2e7b 100644 --- a/base/coq/Prelude/Pair.v +++ b/base/coq/Prelude/Pair.v @@ -35,22 +35,7 @@ End SecPair. Arguments pair_ {Shape} {Pos} {A} {B}. -(* ShareableArgs instance for Pair *) - -Instance ShareableArgsPair {Shape : Type} {Pos : Shape -> Type} (A B : Type) - `{Injectable Share.Shape Share.Pos Shape Pos} - `{ShareableArgs Shape Pos A} - `{ShareableArgs Shape Pos B} - : ShareableArgs Shape Pos (Pair Shape Pos A B) := { - shareArgs p := match p with - | pair_ fx fy => cbneed Shape Pos fx >>= fun sx => - cbneed Shape Pos fy >>= fun sy => - (pure (pair_ sx sy)) - end - }. - (* Normalform instance for Pair *) - Section SecNFPair. Variable Shape : Type. @@ -75,3 +60,16 @@ Section SecNFPair. := { nf' := nf'Pair }. End SecNFPair. + +(* ShareableArgs instance for Pair *) +Instance ShareableArgsPair {Shape : Type} {Pos : Shape -> Type} (A B : Type) + `{Injectable Share.Shape Share.Pos Shape Pos} + `{SAA : ShareableArgs Shape Pos A} + `{SAB : ShareableArgs Shape Pos B} + : ShareableArgs Shape Pos (Pair Shape Pos A B) := { + shareArgs p := match p with + | pair_ fx fy => cbneed Shape Pos (@shareArgs Shape Pos A SAA) fx >>= fun sx => + cbneed Shape Pos (@shareArgs Shape Pos B SAB) fy >>= fun sy => + (pure (pair_ sx sy)) + end + }. diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 56d64f42..b9ef1cbc 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -5,8 +5,9 @@ module FreeC.Backend.Coq.Converter.TypeDecl where import Control.Monad ( foldM, mapAndUnzipM, replicateM, zipWithM ) import Control.Monad.Extra ( concatMapM ) -import Data.List ( nub, partition ) +import Data.List ( nub, partition, intercalate ) -- TODO: Remove intercalate import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map import Data.Maybe ( catMaybes, fromJust ) import qualified Data.Set as Set @@ -207,11 +208,111 @@ convertDataDecl (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do convertDataDecl (IR.TypeSynDecl _ _ _ _) = error "convertDataDecl: Type synonym not allowed." ------- Instance generation ------- --- builds instances for all available typeclasses (currently Normalform) +------------------------------------------------------------------------------- +-- Instance Generation -- +------------------------------------------------------------------------------- + +-- | Builds instances for all supported typeclasses. +-- Currently, only a @Normalform@ instance is generated. +-- +-- [...] +-- +-- Suppose we have a type +-- @data T a1 ... an = C1 a11 ... a1m1 | ... | Ck ak1 ... akmk@. +-- We wish to generate an instance of class @C@ providing the function +-- @f : T a1 ... an -> B@, where @B@ is a type. +-- For example, for the @Normalform@ class @f@ would be +-- @nf' : T a1 ... an -> Free Shape Pos (T a1 ... an)@. +-- +-- The generated function has the following basic structure: +-- +-- @f'T < class-specific binders > (x : T a1 ... an) : B +-- := match x with +-- | C1 fx11 ... fx1m1 => < buildValue x [fx11, ..., fx1m1] > +-- | ... +-- | Ck fxk1 ... fxkmk => < buildValue x [fxk1, ..., fxkmk] > +-- end. +-- +-- @buildValue x [fxi1, ..., fximi]@ represents class-specific code that +-- actually constructs a value of type @B@ when given @x@ and the +-- constructor's parameters as arguments. +-- +-- For example, for a @Normalform@ instance of a type +-- @data List a = Nil | Cons a (List a)@, +-- the function would look as follows. +-- +-- @nf'List_ {Shape : Type} {Pos : Shape -> Type} +-- {a b : Type} `{Normalform Shape Pos a b} +-- (x : List Shape Pos a) +-- : Free Shape Pos (List Identity.Shape Identity.Pos b) +-- := match x with +-- | nil => pure nil +-- | cons fx_0 fx_1 => nf fx_0 >>= fun nx_0 => +-- fx_1 >>= fun x_1 => +-- nf'List x_1 >>= fun nx_1 => +-- pure (cons (pure nx_0) (pure nx_1)) +-- end. +-- +-- Typically, @buildValue@ will use the class function @f@ on all components, +-- then reconstruct the value using the results of those function calls. +-- In the example above, we use @nf@ on @fx_0@ of type @a@. @nf fx_0@ means +-- the same as @fx_0 >>= fun x_0 => nf' x_0@. +-- +-- Since we translate types in topological order and @C@ instances exist for +-- all previously translated types (and types from the Prelude), we can use +-- @f@ on most arguments. +-- For all type variables, we introduce class constraints into the type +-- signature of the function. +-- However, this is not possible for (indirectly) recursive arguments. +-- +-- A directly recursive argument has the type @T t1 ... tn@, where @ti@ are +-- type expressions (not necessarily type variables). We assume that @ti'@ +-- does not contain @T@ for any @i@, as this would constitute a non-positive +-- occurrence of @T@ and make @T@ invalid in Coq. +-- For these arguments, instead of the function @f@ we call @fT@ recursively. +-- +-- An indirectly recursive argument is an argument of a type that is not @T@, +-- but contains @T@. +-- These arguments are problematic because we can neither use @f@ on them +-- (as that would generally require a @C@ instance of @T@) nor can we use +-- @fT@. +-- +-- The problem is solved by introducing a local function fT' for every type +-- @T'@ that contains @T@ that inlines the definition of a @T'@ instance of +-- @C@, and call this functions for arguments of type @T'@. +-- These local functions are as polymorphic as possible to reduce the number +-- of local functions we need. +-- +-- For example, if we want to generate an instance for the Haskell type +-- @data Forest a = AForest [Forest a] +-- | IntForest [Forest Int] +-- | BoolForest [ForestBool]@, +-- only one local function is needed. +-- @fListForest_ : List Shape Pos (Forest Shape Pos a) +-- -> Free Shape Pos (List Identity.Shape Identity.Pos +-- (Forest Identity.Shape Identity.Pos b))@ +-- +-- To generate these local function, for every type expression @aij@ in the +-- constructors of @T@, we collect all types that contain the original type +-- @T@. +-- More specifically, a type expression @T' t1 ... tm@ is collected if +-- @ti = T t1' ... tn'@ for some type expressions @t1', ..., tn'@, or if @ti@ +-- is collected for some @i@. +-- During this process, any type expression that does not contain @T@ is +-- replaced by a placeholder variable "_". +-- +-- We keep track of which types correspond to which function with a map. +-- +-- The generated functions @fT1, ..., fTn@ for @n@ mutually recursive types +-- @T1, ... Tn@ are a set of @n@ @Fixpoint@ definitions linked with @with@. +-- Indirectly recursive types and local functions based on them are computed +-- for each type. +-- In this case, a type @T'@ is considered indirectly recursive if it +-- contains any of the types @T1, ..., Tn@. +-- Arguments of type @Ti@ can be treated like directly recursive arguments. generateAllInstances :: [IR.TypeDecl] -> Converter [Coq.Sentence] generateAllInstances dataDecls = do - let argTypes = map (concatMap IR.conDeclFields . IR.dataDeclCons) dataDecls -- :: [[IR.Type]] + let argTypes = map (concatMap IR.conDeclFields . IR.dataDeclCons) dataDecls argTypesExpanded <- mapM (mapM expandAllTypeSynonyms) argTypes -- :: [[IR.Type]] let types = map (nub . reverse . concatMap collectSubTypes) argTypesExpanded @@ -224,7 +325,8 @@ generateAllInstances dataDecls = do conNames = map IR.typeDeclQName dataDecls - -- makes instances for a specific typeclass + -- | Builds instances for a strongly connected component of types + -- for a specific typeclass. buildInstances :: [[IR.Type]] -- for each dataDecl, the types contained in it with nested occurrences of one of the dataDecls -> String -- function prefix, i.e. what functions will be called (e.g. nf' or shareArgs) @@ -279,11 +381,11 @@ generateAllInstances dataDecls = do -> Converter Coq.Sentence buildFunctions topLevelVars typeLevelMaps topLevelBindersAndReturnTypes = do fixBodies <- zipWithM - (uncurry (uncurry (uncurry makeFixBody))) -- TODO Refactor more? - (zip (zip (zip typeLevelMaps topLevelVars) declTypes) - topLevelBindersAndReturnTypes) recTypeList + (uncurry (uncurry (uncurry makeFixBody))) -- I don't like this... + (zip (zip (zip typeLevelMaps topLevelVars) declTypes) + topLevelBindersAndReturnTypes) recTypeList return - $ Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) + $ Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) makeFixBody :: TypeMap -> Coq.Qualid @@ -326,8 +428,7 @@ generateAllInstances dataDecls = do :: TypeMap -> IR.Type -> IR.ConName - -> Converter Coq.Equation -- TODO: rename type args before unification - + -> Converter Coq.Equation buildEquation m t conName = do conEntry <- lookupEntryOrFail NoSrcSpan IR.ValueScope conName let retType = entryReturnType conEntry @@ -342,14 +443,17 @@ generateAllInstances dataDecls = do rhs <- buildValue m conIdent (zip modArgTypes conArgIdents) return $ Coq.equation lhs rhs - ------- Type analysis ------- - -- This function collects all fully-applied type constructors + ----------------------------------------------------------------------------- + -- Type Analysis -- + ----------------------------------------------------------------------------- + + -- This function collects all fully-applied type constructors -- of arity at least 1 (including their arguments) that occur in the given type. -- All arguments that do not contain occurrences of the types for which -- we are defining an instance are replaced by the type variable "_". - -- The resulting list contains (in reverse topological order) exactly all - -- types for which we must define a separate function in the instance - -- definition, where all occurrences of "_" represent the polymorphic + -- The resulting list contains (in reverse topological order) exactly all + -- types for which we must define a separate function in the instance + -- definition, where all occurrences of "_" represent the polymorphic -- components of the function. collectSubTypes :: IR.Type -> [IR.Type] collectSubTypes = collectFullyAppliedTypes True @@ -380,9 +484,14 @@ generateAllInstances dataDecls = do -- Type variables and function types are not relevant and are replaced by "_". stripType' _ _ = IR.TypeVar NoSrcSpan "_" ------------ Functions specific to a typeclass ------------ +------------------------------------------------------------------------------- +-- Typeclasses -- +------------------------------------------------------------------------------- + ------- Functions for building Normalform instances ------- --- regular binders, top-level variable binder, return type of function belonging to type, class name + +-- regular binders, top-level variable binder, return type of function belonging to type, +-- type of instance. nfBindersAndReturnType :: IR.Type -> Coq.Qualid @@ -401,6 +510,8 @@ nfBindersAndReturnType t varName = do let funcRetType = applyFree targetType return (binders, topLevelVarBinder, funcRetType, instanceRetType) +-- | Builds a normalized @Free@ value for the given constructor +-- and constructor parameters. buildNormalformValue :: TypeMap -> Coq.Qualid -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term buildNormalformValue nameMap consName = buildNormalformValue' [] @@ -427,7 +538,11 @@ buildNormalformValue nameMap consName = buildNormalformValue' [] $ applyBind (Coq.app (Coq.Qualid (Coq.bare "nf")) [Coq.Qualid varName]) cont ----------------- Helper functions for types ----------------- + +------------------------------------------------------------------------------- +-- Helper functions -- +------------------------------------------------------------------------------- + -- Like showPretty, but uses the Coq identifiers of the type and its components. showPrettyType :: IR.Type -> Converter String @@ -445,7 +560,7 @@ showPrettyType (IR.TypeApp _ l r) = do showPrettyType (IR.FuncType _ _ _) = error "Function types should have been eliminated." --- Converts a data declaration to a type by applying its constructor to the +-- Converts a data declaration to a type by applying its constructor to the -- correct number of variables, denoted by underscores. dataDeclToType :: IR.TypeDecl -> IR.Type dataDeclToType dataDecl = IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) @@ -465,7 +580,6 @@ insertFreshVariables (IR.TypeApp srcSpan l r) = do -- Function types should not occur, but are also simply returned. insertFreshVariables t = return t -------------------- Coq AST helper functions/shortcuts ------------------- -- Binders for (implicit) Shape and Pos arguments. -- freeArgsBinders = [ {Shape : Type}, {Pos : Shape -> Type} ] freeArgsBinders :: [Coq.Binder] @@ -499,7 +613,9 @@ buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder buildConstraint ident args = Coq.Generalized Coq.Implicit (Coq.app (Coq.Qualid (Coq.bare ident)) (shapeAndPos ++ map Coq.Qualid args)) --- converts our type into a Coq type (a term) with new variables for all don't care values. +-- converts our type into a Coq type (a term) with the specified +-- additional arguments (e.g. Shape and Pos) and new variables for all +-- underscores. -- We can also choose the prefix for those variables. toCoqType :: String -> [Coq.Term] -> IR.Type -> Converter (Coq.Term, [Coq.Qualid]) @@ -517,12 +633,12 @@ toCoqType _ _ (IR.FuncType _ _ _) = error "Function types should have been eliminated." ------------------------------- --- Function name map +-- Function name map -- For each type that contains one of the types we are defining --- an instance for - directly or indirectly -, we insert an +-- an instance for - directly or indirectly -, we insert an -- entry into a map that returns the name of the function we -- should call on a value of that type. --- For all types that do not have a corresponding entry, we +-- For all types that do not have a corresponding entry, we -- can assume that an instance already exists. type TypeMap = IR.Type -> Maybe Coq.Qualid @@ -535,8 +651,8 @@ lookupType = flip ($) insertType :: IR.Type -> Coq.Qualid -> TypeMap -> TypeMap insertType k v m t = if k == t then Just v else m t --- Creates an entry with a unique name for each of the given types and --- inserts them into the given map. +-- Creates an entry with a unique name for each of the given types and +-- inserts them into the given map. nameFunctionsAndInsert :: String -> TypeMap -> [IR.Type] -> Converter TypeMap nameFunctionsAndInsert prefix = foldM (nameFunctionAndInsert prefix) @@ -553,6 +669,6 @@ nameFunction prefix t = do prettyType <- showPrettyType t freshCoqIdent (prefix ++ prettyType) --- Produces n new Coq identifiers (Qualids) +-- Produces @n@ new Coq identifiers (Qualids) freshQualids :: Int -> String -> Converter [Coq.Qualid] freshQualids n prefix = replicateM n (Coq.bare <$> freshCoqIdent prefix) diff --git a/tool/full-test.sh b/tool/full-test.sh index 3c2bb0fb..491bec4a 100755 --- a/tool/full-test.sh +++ b/tool/full-test.sh @@ -247,7 +247,7 @@ function check_required_software() { local program_not_found_counter=0 check_version "GHC" ghc '8.6.5' >> "$temp_log" check_version "Cabal" cabal '3.*' >> "$temp_log" - check_version "Coq" coqc '8.8.*|8.9.*|8.10.*|8.11.*' >> "$temp_log" + check_version "Coq" coqc '8.10.*|8.11.*|8.12.*' >> "$temp_log" check_version "HLint" hlint '3.1.*' >> "$temp_log" check_version "Floskell" floskell '0.10.4' >> "$temp_log" check_version "Agda" agda '2.6.1' >> "$temp_log" From 65e8311ec11152f78dc8e67667cd3730d375ece4 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Thu, 10 Sep 2020 12:26:18 +0200 Subject: [PATCH 025/120] Merge partially with issue-183 #150 --- base/coq/Free.v | 3 +- base/coq/Free/Class.v | 3 +- base/coq/Free/Class/Injectable.v | 22 ++++---- base/coq/Free/Class/Normalform.v | 8 +-- base/coq/Free/Class/ShareableArgs.v | 6 +-- base/coq/Free/Class/Strategy.v | 12 +++++ base/coq/Free/Instance/Comb.v | 2 +- base/coq/Free/Instance/Maybe.v | 38 +++++++------- base/coq/Free/Instance/ND.v | 58 ++++++++++----------- base/coq/Free/Instance/Share.v | 20 ++++---- base/coq/Free/Instance/Trace.v | 79 +++++++++++++++-------------- base/coq/Free/Malias.v | 46 ++++++++++++----- base/coq/Free/Util/Search.v | 2 +- base/coq/Free/Util/Sharing.v | 2 +- base/coq/Prelude/Bool.v | 2 +- base/coq/Prelude/Integer.v | 2 +- base/coq/Prelude/List.v | 6 +-- base/coq/Prelude/Pair.v | 18 +------ base/coq/Prelude/Unit.v | 2 +- 19 files changed, 175 insertions(+), 156 deletions(-) create mode 100644 base/coq/Free/Class/Strategy.v diff --git a/base/coq/Free.v b/base/coq/Free.v index 547590df..be83b633 100644 --- a/base/coq/Free.v +++ b/base/coq/Free.v @@ -2,5 +2,6 @@ From Base Require Export Free.Class. From Base Require Export Free.ForFree. From Base Require Export Free.Induction. From Base Require Export Free.Instance.Identity. +From Base Require Export Free.Malias. From Base Require Export Free.Monad. -From Base Require Export Free.Tactic.Simplify. \ No newline at end of file +From Base Require Export Free.Tactic.Simplify. diff --git a/base/coq/Free/Class.v b/base/coq/Free/Class.v index 870b6962..f95b8e92 100644 --- a/base/coq/Free/Class.v +++ b/base/coq/Free/Class.v @@ -1,6 +1,5 @@ From Base Require Export Free.Class.Injectable. From Base Require Export Free.Class.Normalform. From Base Require Export Free.Class.Partial. -From Base Require Export Free.Class.Shareable. From Base Require Export Free.Class.ShareableArgs. -From Base Require Export Free.Class.Traceable. +From Base Require Export Free.Class.Strategy. diff --git a/base/coq/Free/Class/Injectable.v b/base/coq/Free/Class/Injectable.v index 2211b88d..dfa8cf1a 100644 --- a/base/coq/Free/Class/Injectable.v +++ b/base/coq/Free/Class/Injectable.v @@ -4,8 +4,8 @@ From Base Require Import Free.Instance.Comb. From Base Require Import Free.Monad. From Base Require Import Free.Class.Partial. -(* injS embeds an effect in an effect stack that contains it. - injP allows us to view a position of an embedded effect as an +(* injS embeds an effect in an effect stack that contains it. + injP allows us to view a position of an embedded effect as an element of the effect itself. *) Class Injectable (SubShape : Type) (SubPos : SubShape -> Type) (SupShape : Type) (SupPos : SupShape -> Type) := @@ -27,12 +27,12 @@ Instance Inject_refl {Shape : Type} {Pos : Shape -> Type} (* An effect is contained in an effect stack if it is its head component. *) Instance Inject_comb {F_Shape : Type} {F_Pos : F_Shape -> Type} - {G_Shape : Type} {G_Pos : G_Shape -> Type} - : Injectable F_Shape F_Pos (Comb.Shape F_Shape G_Shape) + {G_Shape : Type} {G_Pos : G_Shape -> Type} + : Injectable F_Shape F_Pos (Comb.Shape F_Shape G_Shape) (Comb.Pos F_Pos G_Pos) | 1 := { injS := inl; injP s := fun p : F_Pos s => p; - (*prjS := fun s => match s with + (*prjS := fun s => match s with | inl s' => Some s' | _ => None end;*) @@ -40,12 +40,12 @@ Instance Inject_comb {F_Shape : Type} {F_Pos : F_Shape -> Type} (* An effect is also contained in an effect stack if it is contained in its tail. *) Instance Inject_rec {F_Shape : Type} {F_Pos : F_Shape -> Type} - {G_Shape : Type} {G_Pos : G_Shape -> Type} - {H_Shape : Type} {H_Pos : H_Shape -> Type} + {G_Shape : Type} {G_Pos : G_Shape -> Type} + {H_Shape : Type} {H_Pos : H_Shape -> Type} `{Injectable F_Shape F_Pos H_Shape H_Pos} - : Injectable F_Shape F_Pos + : Injectable F_Shape F_Pos (Comb.Shape G_Shape H_Shape) (Comb.Pos G_Pos H_Pos) | 2 := { - injS := fun s => inr (injS s); + injS := fun s => inr (injS s); injP s := fun p => injP p; (*prjS := fun s => match s with | inr s' => prjS s' @@ -63,9 +63,9 @@ Fixpoint embed {A : Type} {Shape : Type} {Pos : Shape -> Type} (Shape' : Type) end. (* Partial instance *) -Instance PartialLifted (Shape : Type) (Pos : Shape -> Type) +Instance PartialLifted (Shape : Type) (Pos : Shape -> Type) (Shape' : Type) (Pos' : Shape' -> Type) `{Injectable Shape Pos Shape' Pos'} `(Partial Shape Pos) : Partial Shape' Pos' := { undefined := fun {A : Type} => embed Shape' Pos' undefined; error := fun {A : Type} (msg : string) => embed Shape' Pos' (error msg) - }. \ No newline at end of file + }. diff --git a/base/coq/Free/Class/Normalform.v b/base/coq/Free/Class/Normalform.v index 9c51673b..d6e0cb83 100644 --- a/base/coq/Free/Class/Normalform.v +++ b/base/coq/Free/Class/Normalform.v @@ -1,5 +1,5 @@ (** Type class for the normalization of data types with effectful components. - Moves effects from components to the root of the expression. + Moves effects from components to the root of the expression. This implementation is based on the following implementation: https://github.com/nbun/mathesis/blob/master/Coq/src/Classes.v *) @@ -20,7 +20,7 @@ Definition nf {Shape : Type} {Pos : Shape -> Type} {A B : Type} Lemma nfImpure {Shape : Type} {Pos : Shape -> Type} {A B : Type} `{Normalform Shape Pos A B} - : forall s (pf : _ -> Free Shape Pos A), + : forall s (pf : _ -> Free Shape Pos A), nf (impure s pf) = impure s (fun p => nf (pf p)). Proof. trivial. Qed. @@ -31,6 +31,6 @@ Proof. trivial. Qed. (* Normalform instance for functions. Effects inside of functions are not pulled to the root. *) -Instance NormalformFunc (Shape : Type) (Pos : Shape -> Type) (A B : Type) +Instance NormalformFunc (Shape : Type) (Pos : Shape -> Type) (A B : Type) : Normalform Shape Pos (A -> B) (A -> B) := - { nf' := pure }. \ No newline at end of file + { nf' := pure }. diff --git a/base/coq/Free/Class/ShareableArgs.v b/base/coq/Free/Class/ShareableArgs.v index 60458f42..895f4a8c 100644 --- a/base/coq/Free/Class/ShareableArgs.v +++ b/base/coq/Free/Class/ShareableArgs.v @@ -1,13 +1,13 @@ From Base Require Import Free.Monad. -Class ShareableArgs (Shape : Type) (Pos : Shape -> Type) +Class ShareableArgs (Shape : Type) (Pos : Shape -> Type) (A : Type) := { shareArgs : A -> Free Shape Pos A }. -(* ShareableArgs instance for functions. +(* ShareableArgs instance for functions. Effects inside of functions are not shared. *) Instance ShareableArgsFunc (Shape : Type) (Pos : Shape -> Type) (A B : Type) : ShareableArgs Shape Pos (A -> B) := - { shareArgs := pure }. \ No newline at end of file + { shareArgs := pure }. diff --git a/base/coq/Free/Class/Strategy.v b/base/coq/Free/Class/Strategy.v new file mode 100644 index 00000000..140040d7 --- /dev/null +++ b/base/coq/Free/Class/Strategy.v @@ -0,0 +1,12 @@ +From Base Require Export Free.Instance.Share. +From Base Require Import Free.Class.Injectable. +From Base Require Import Free.Class.ShareableArgs. +From Base Require Import Free.Monad. + +Class Strategy (Shape : Type) (Pos : Shape -> Type) := + { + share : forall {A : Type} `{ShareableArgs Shape Pos A}, + Free Shape Pos A -> Free Shape Pos (Free Shape Pos A); + call : forall {A : Type}, + Free Shape Pos A -> Free Shape Pos (Free Shape Pos A); + }. diff --git a/base/coq/Free/Instance/Comb.v b/base/coq/Free/Instance/Comb.v index 95d7b110..386fcd18 100644 --- a/base/coq/Free/Instance/Comb.v +++ b/base/coq/Free/Instance/Comb.v @@ -5,7 +5,7 @@ Module Comb. (* Shape and position function for the combination of effects. *) Definition Shape (F_Shape : Type) (G_Shape : Type) : Type := sum F_Shape G_Shape. - Definition Pos {F_Shape : Type} {G_Shape : Type} + Definition Pos {F_Shape : Type} {G_Shape : Type} (F_Pos : F_Shape -> Type) (G_Pos : G_Shape -> Type) (s : Shape F_Shape G_Shape) : Type := match s with | inl x => F_Pos x diff --git a/base/coq/Free/Instance/Maybe.v b/base/coq/Free/Instance/Maybe.v index ba649355..9180f23f 100644 --- a/base/coq/Free/Instance/Maybe.v +++ b/base/coq/Free/Instance/Maybe.v @@ -13,24 +13,24 @@ Module Maybe. Module Import Monad. Definition Maybe (A : Type) : Type := Free Shape Pos A. Definition Just {A : Type} (x : A) : Maybe A := pure x. - Definition Nothing {A : Type} : Maybe A := + Definition Nothing {A : Type} : Maybe A := impure tt (fun (p : Pos tt) => match p with end). (* Versions of the smart constructors that automatically embed values in an effect stack *) - Definition Just_inj {A : Type} - (Shape' : Type) - (Pos' : Shape' -> Type) - `{Injectable Shape Pos Shape' Pos'} - (x : A) - : Free Shape' Pos' A + Definition Just_inj (Shape' : Type) + (Pos' : Shape' -> Type) + `{Injectable Shape Pos Shape' Pos'} + {A : Type} + (x : A) + : Free Shape' Pos' A := pure x. - Definition Nothing_inj {A : Type} - (Shape' : Type) - (Pos' : Shape' -> Type) - `{Injectable Shape Pos Shape' Pos'} - : Free Shape' Pos' A - := impure (injS tt) (fun p : Pos' (injS tt) => + Definition Nothing_inj (Shape' : Type) + (Pos' : Shape' -> Type) + `{Injectable Shape Pos Shape' Pos'} + {A : Type} + : Free Shape' Pos' A + := impure (injS tt) (fun p : Pos' (injS tt) => (fun (x : Void) => match x with end) (injP p)). End Monad. @@ -40,12 +40,12 @@ Module Maybe. Definition PMaybe {Shape' : Type} (Pos' : Shape' -> Type) := Comb.Pos Pos Pos'. - Fixpoint runMaybe {A : Type} - {Shape' : Type} - {Pos' : Shape' -> Type} - (fm : Free (SMaybe Shape') (PMaybe Pos') A) - : Free Shape' Pos' (option A) - := match fm with + Fixpoint runMaybe {Shape' : Type} + {Pos' : Shape' -> Type} + {A : Type} + (fm : Free (SMaybe Shape') (PMaybe Pos') A) + : Free Shape' Pos' (option A) + := match fm with | pure x => pure (Some x) | impure (inl s) _ => pure None | impure (inr s) pf => impure s (fun p : Pos' s => runMaybe (pf p)) diff --git a/base/coq/Free/Instance/ND.v b/base/coq/Free/Instance/ND.v index 708bd381..0e04b6f0 100644 --- a/base/coq/Free/Instance/ND.v +++ b/base/coq/Free/Instance/ND.v @@ -1,4 +1,4 @@ -(** * Definition of the non-determinism effect in terms of the free monad. *) + (** * Definition of the non-determinism effect in terms of the free monad. *) From Base Require Import Free. From Base Require Import Free.Instance.Comb. @@ -23,35 +23,35 @@ Module ND. Module Import Monad. Definition ND (A : Type) : Type := Free Shape Pos A. - Definition Fail {A : Type} (Shape' : Type) (Pos' : Shape' -> Type) - `{Injectable Shape Pos Shape' Pos'} + Definition Fail (Shape' : Type) (Pos' : Shape' -> Type) + `{Injectable Shape Pos Shape' Pos'} {A : Type} : Free Shape' Pos' A := impure (injS sfail) (fun p => (fun (x : Void) => match x with end) (injP p)). - Definition Choice_ {A : Type} (Shape' : Type) (Pos' : Shape' -> Type) - `{Injectable Shape Pos Shape' Pos'} mid l r - : Free Shape' Pos' A := - let s := injS (schoice mid) + Definition Choice_ (Shape' : Type) (Pos' : Shape' -> Type) + `{Injectable Shape Pos Shape' Pos'} {A : Type} mid l r + : Free Shape' Pos' A := + let s := injS (schoice mid) in impure s (fun p : Pos' s => if injP p : Pos (schoice mid) then l else r). - (* Curry notation for the choice operator. + (* Curry notation for the choice operator. The ID is set by the sharing handler. *) - Definition Choice {A} Shape Pos `{I : Injectable ND.Shape ND.Pos Shape Pos} x y - := @Choice_ A Shape Pos I None x y. + Definition Choice Shape Pos {A} `{I : Injectable ND.Shape ND.Pos Shape Pos} x y + := @Choice_ Shape Pos I A None x y. End Monad. (* Handlers for non-determinism and call-time choice. *) Module Import Handler. (* Helper definitions and handler for non-determinism. *) Definition SChoice (Shape' : Type) := Comb.Shape Shape Shape'. - Definition PChoice {Shape' : Type} (Pos' : Shape' -> Type) + Definition PChoice {Shape' : Type} (Pos' : Shape' -> Type) := Comb.Pos Pos Pos'. - Fixpoint runChoice {A : Type} - {Shape' : Type} - {Pos' : Shape' -> Type} - (fc : Free (SChoice Shape') (PChoice Pos') A) - : Free Shape' Pos' (Tree A) + Fixpoint runChoice {Shape' : Type} + {Pos' : Shape' -> Type} + {A : Type} + (fc : Free (SChoice Shape') (PChoice Pos') A) + : Free Shape' Pos' (Tree A) := match fc with | pure x => pure (Leaf x) | impure (inl ND.sfail) _ => pure (Empty A) @@ -63,37 +63,37 @@ Module ND. impure s (fun p => runChoice (pf p)) end. - (* Helper definitions and handler for sharing combined with non-determinism + (* Helper definitions and handler for sharing combined with non-determinism (call-time choice). *) - Definition SNDShare (Shape' : Type) + Definition SNDShare (Shape' : Type) := Comb.Shape Share.Shape (SChoice Shape'). - Definition PNDShare {Shape' : Type} (Pos' : Shape' -> Type) + Definition PNDShare {Shape' : Type} (Pos' : Shape' -> Type) := Comb.Pos Share.Pos (PChoice Pos'). - Fixpoint runNDSharing {A : Type} - {Shape' : Type} - {Pos' : Shape' -> Type} + Fixpoint runNDSharing {Shape' : Type} + {Pos' : Shape' -> Type} + {A : Type} (n : nat * nat) - (fs : Free (SNDShare Shape') (PNDShare Pos') A) - : Free (SChoice Shape') (PChoice Pos') A + (fs : Free (SNDShare Shape') (PNDShare Pos') A) + : Free (SChoice Shape') (PChoice Pos') A := let fix nameChoices (next : nat) (state : nat * nat) - (scope : nat * nat) - (scopes : list (nat * nat)) + (scope : nat * nat) + (scopes : list (nat * nat)) (fs : Free (SNDShare Shape') (PNDShare Pos') A) - : Free (SChoice Shape') (PChoice Pos') A + : Free (SChoice Shape') (PChoice Pos') A := match fs with (* inside scope handler *) | pure x => pure x | impure (inl (Share.sbsharing n')) pf => (* open nested scope *) nameChoices 1 state n' (cons n' scopes) (pf tt) - | impure (inl (Share.sesharing n')) pf => + | impure (inl (Share.sesharing n')) pf => match scopes with (* leave nested scope *) | cons _ (cons j js) as ks => nameChoices next state j ks (pf tt) (* leave outermost scope *) | _ => runNDSharing state (pf tt) end - | impure (inl Share.sget) pf => + | impure (inl Share.sget) pf => nameChoices next state scope scopes (pf state) (* get state *) | impure (inl (Share.sput n')) pf => (* set new state *) nameChoices next n' scope scopes (pf tt) diff --git a/base/coq/Free/Instance/Share.v b/base/coq/Free/Instance/Share.v index 4aa28cab..9663885e 100644 --- a/base/coq/Free/Instance/Share.v +++ b/base/coq/Free/Instance/Share.v @@ -6,14 +6,14 @@ From Base Require Import Free.Monad. Module Share. (* Shape and position function *) - Inductive Shape : Type := + Inductive Shape : Type := | sget : Shape | sput : (nat * nat) -> Shape - | sbsharing : (nat * nat) -> Shape + | sbsharing : (nat * nat) -> Shape | sesharing : (nat * nat) -> Shape. - Definition Pos (s : Shape) : Type := - match s with + Definition Pos (s : Shape) : Type := + match s with | sget => (nat * nat) | _ => unit end. @@ -22,23 +22,23 @@ Module Share. Module Import Monad. Definition Share (A : Type) : Type := Free Shape Pos A. - Definition Get (Shape' : Type) (Pos' : Shape' -> Type) - `{Injectable Shape Pos Shape' Pos'} + Definition Get (Shape' : Type) (Pos' : Shape' -> Type) + `{Injectable Shape Pos Shape' Pos'} : Free Shape' Pos' (nat * nat) := impure (injS sget) (fun p => pure (injP p)). - Definition Put (Shape' : Type) (Pos' : Shape' -> Type) (n : nat * nat) - `{Injectable Shape Pos Shape' Pos'} + Definition Put (Shape' : Type) (Pos' : Shape' -> Type) (n : nat * nat) + `{Injectable Shape Pos Shape' Pos'} : Free Shape' Pos' unit := impure (injS (sput n)) (fun _ => pure tt). Definition BeginShare (Shape' : Type) (Pos' : Shape' -> Type) (n : nat * nat) - `{Injectable Shape Pos Shape' Pos'} + `{Injectable Shape Pos Shape' Pos'} : Free Shape' Pos' unit := impure (injS (sbsharing n)) (fun _ => pure tt). Definition EndShare (Shape' : Type) (Pos' : Shape' -> Type) (n : nat * nat) - `{Injectable Shape Pos Shape' Pos'} + `{Injectable Shape Pos Shape' Pos'} : Free Shape' Pos' unit := impure (injS (sesharing n)) (fun _ => pure tt). End Monad. diff --git a/base/coq/Free/Instance/Trace.v b/base/coq/Free/Instance/Trace.v index ce8a2297..3843e9ab 100644 --- a/base/coq/Free/Instance/Trace.v +++ b/base/coq/Free/Instance/Trace.v @@ -6,6 +6,7 @@ From Base Require Import Free.Instance.Share. From Base Require Import Free.Util.Sharing. From Base Require Import Free.Util.Void. Require Export Coq.Strings.String. +Export Strings.String.StringSyntax. Module Trace. @@ -16,78 +17,86 @@ Module Trace. (* Type synonym and smart constructors for the tracing effect. *) Module Import Monad. Definition Trace (A : Type) : Type := Free Shape Pos A. - Definition NoMsg {A : Type} - (Shape' : Type) - (Pos' : Shape' -> Type) - `{Injectable Shape Pos Shape' Pos'} - (x : A) - : Free Shape' Pos' A := pure x. - Definition Msg {A : Type} - (Shape' : Type) + Definition NoMsg (Shape' : Type) (Pos' : Shape' -> Type) - `{Injectable Shape Pos Shape' Pos'} - (mid : option ID) - (msg : string) - (x : Free Shape' Pos' A) + {A : Type} + `{Injectable Shape Pos Shape' Pos'} + (x : A) + : Free Shape' Pos' A := pure x. + Definition Msg (Shape' : Type) + (Pos' : Shape' -> Type) + `{Injectable Shape Pos Shape' Pos'} + {A : Type} + (mid : option ID) + (msg : string) + (x : Free Shape' Pos' A) : Free Shape' Pos' A := impure (injS (mid, msg)) (fun tt => x). + (* Tracing function *) + Definition trace (Shape' : Type) (Pos' : Shape' -> Type) + `{I: Injectable Shape Pos Shape' Pos'} + {A : Type} + (msg : string) (p : Free Shape' Pos' A) + : Free Shape' Pos' A + := @Msg Shape' Pos' I A None msg p. + End Monad. (* Handlers for tracing and sharing combined with tracing. *) Module Import Handler. (* Helper definitions and handler for the tracing effect. *) Definition STrace (Shape' : Type) := Comb.Shape Shape Shape'. - Definition PTrace {Shape' : Type} (Pos' : Shape' -> Type) + Definition PTrace {Shape' : Type} (Pos' : Shape' -> Type) := Comb.Pos Trace.Pos Pos'. - Fixpoint runTracing {A : Type} - {Shape' : Type} - {Pos' : Shape' -> Type} - (fm : Free (STrace Shape') (PTrace Pos') A) + Fixpoint runTracing {Shape' : Type} + {Pos' : Shape' -> Type} + {A : Type} + (fm : Free (STrace Shape') (PTrace Pos') A) : Free Shape' Pos' (A * list (option ID * string)) - := match fm with + := match fm with | pure x => pure (x,nil) - | impure (inl s) pf => + | impure (inl s) pf => runTracing (pf tt) >>= fun pair => match pair with - | (x,msgs) => pure (x,cons s msgs) + | (x,msgs) => pure (x,cons s msgs) end | impure (inr s) pf => impure s (fun p => runTracing (pf p)) end. (* Helper definitions and handler for sharing combined with tracing. *) - Definition STrcShare (Shape' : Type) + Definition STrcShare (Shape' : Type) := Comb.Shape Share.Shape (STrace Shape'). Definition PTrcShare {Shape' : Type} (Pos' : Shape' -> Type) := Comb.Pos Share.Pos (PTrace Pos'). - Fixpoint runTraceSharing {A : Type} - {Shape' : Type} - {Pos' : Shape' -> Type} - (n : nat * nat) - (fs : Free (STrcShare Shape') (PTrcShare Pos') A) - : Free (STrace Shape') (PTrace Pos') A + Fixpoint runTraceSharing {Shape' : Type} + {Pos' : Shape' -> Type} + {A : Type} + (n : nat * nat) + (fs : Free (STrcShare Shape') (PTrcShare Pos') A) + : Free (STrace Shape') (PTrace Pos') A := let fix nameMessages (next : nat) (state : nat * nat) - (scope : nat * nat) - (scopes : list (nat * nat)) + (scope : nat * nat) + (scopes : list (nat * nat)) (fs : Free (STrcShare Shape') (PTrcShare Pos') A) : Free (STrace Shape') (PTrace Pos') A := match fs with (* inside scope handler *) | pure x => pure x | impure (inl (Share.sbsharing n')) pf => (* open nested scope *) nameMessages 1 state n' (cons n' scopes) (pf tt) - | impure (inl (Share.sesharing n')) pf => + | impure (inl (Share.sesharing n')) pf => match scopes with (* leave nested scope *) | cons _ (cons j js) as ks => nameMessages next state j ks (pf tt) (* leave outermost scope *) | _ => runTraceSharing state (pf tt) end - | impure (inl Share.sget) pf => + | impure (inl Share.sget) pf => nameMessages next state scope scopes (pf state) (* get state *) | impure (inl (Share.sput n')) pf => (* set new state *) nameMessages next n' scope scopes (pf tt) - | impure (inr (inl (_,msg))) pf => + | impure (inr (inl (_,msg))) pf => (* mark the scope of a message *) let x := nameMessages (next + 1) state scope scopes (pf tt) in Msg (STrace Shape') (PTrace Pos') (Some (tripl scope next)) msg x @@ -109,12 +118,6 @@ Module Trace. End Handler. - (* Traceable instance for the Trace effect. *) - Instance Trace (Shape' : Type) (Pos' : Shape' -> Type) - `{I: Injectable Shape Pos Shape' Pos'} - : Traceable Shape' Pos' := { - trace A msg p := @Msg A Shape' Pos' I None msg p - }. (* There is no Partial instance. *) End Trace. diff --git a/base/coq/Free/Malias.v b/base/coq/Free/Malias.v index 5e969a4b..e6e92359 100644 --- a/base/coq/Free/Malias.v +++ b/base/coq/Free/Malias.v @@ -1,19 +1,21 @@ -(** Operators that model call-by-value, call-by-name and call-by-need +(** Operators that model call-by-value, call-by-name and call-by-need evaluation. *) -From Base Require Import Free. -From Base Require Export Free.Instance.Comb. -From Base Require Export Free.Instance.Share. +From Base Require Import Free.Class.Injectable. +From Base Require Import Free.Class.ShareableArgs. +From Base Require Import Free.Class.Strategy. +From Base Require Import Free.Instance.Comb. +From Base Require Import Free.Monad. (* An operator to model call-by-value evaluation *) -Definition cbv {A : Type} (Shape : Type) (Pos : Shape -> Type) (p : Free Shape Pos A) +Definition cbv {A : Type} (Shape : Type) (Pos : Shape -> Type) (p : Free Shape Pos A) : Free Shape Pos (Free Shape Pos A) := p >>= fun x => pure (pure x). (* An operator to model call-by-name evaluation *) Definition cbn {A : Type} (Shape : Type) (Pos : Shape -> Type) - (p : Free Shape Pos A) - : Free Shape Pos (Free Shape Pos A) := + (p : Free Shape Pos A) + : Free Shape Pos (Free Shape Pos A) := pure p. Section SecCbneed. @@ -42,17 +44,33 @@ Definition cbneed {A : Type} pure x'). End SecCbneed. -(* Shareable instances. *) + +(* Strategy instances for different evaluation strategies *) + +(* Strategy instance for call-by-need evaluation. *) Instance Cbneed (Shape : Type) (Pos : Shape -> Type) `{I : Injectable Share.Shape Share.Pos Shape Pos} - : Shareable Shape Pos | 1 := { - share A S p := @cbneed Shape Pos A I (@shareArgs Shape Pos A S) p + : Strategy Shape Pos | 1 := { + share A S := @cbneed Shape Pos A I (@shareArgs Shape Pos A S); + call A := @pure Shape Pos (Free Shape Pos A) }. -(* The Share effect is not actually needed, but we need to +(* Strategy instance for call-by-name evaluation. + The Share effect is not actually needed, but we need to ensure it is there so cbn is compatible with share. *) -Instance Cbn (Shape : Type) (Pos : Shape -> Type) +Instance Cbn (Shape : Type) (Pos : Shape -> Type) + `{Injectable Share.Shape Share.Pos Shape Pos} + : Strategy Shape Pos | 2 := { + share A S := @cbn A Shape Pos; (* share = pure *) + call A := @cbn A Shape Pos (* call = pure *) +}. + +(* Strategy instance for call-by-value evaluation. + The Share effect is not actually needed, but we need to + ensure it is there so cbv is compatible with share. *) +Instance Cbv (Shape : Type) (Pos : Shape -> Type) `{Injectable Share.Shape Share.Pos Shape Pos} - : Shareable Shape Pos | 2 := { - share A S p := @cbn A Shape Pos p + : Strategy Shape Pos | 2 := { + share A S := @cbv A Shape Pos; (* share = pure *) + call A := @cbv A Shape Pos (* call = pure *) }. diff --git a/base/coq/Free/Util/Search.v b/base/coq/Free/Util/Search.v index 25f75136..cb6be819 100644 --- a/base/coq/Free/Util/Search.v +++ b/base/coq/Free/Util/Search.v @@ -1,4 +1,4 @@ -(** Definition of choice trees and the depth-first search algorithm, +(** Definition of choice trees and the depth-first search algorithm, as well as lists where entries have IDs and a function that filters out entries with duplicate IDs. *) diff --git a/base/coq/Free/Util/Sharing.v b/base/coq/Free/Util/Sharing.v index 5eb2cfb7..1ec9d8fd 100644 --- a/base/coq/Free/Util/Sharing.v +++ b/base/coq/Free/Util/Sharing.v @@ -6,4 +6,4 @@ Definition ID : Type := (nat * nat * nat). Set Implicit Arguments. (* Helper function to construct a triple from a pair and a single value *) Definition tripl A B C (p : A * B) (c : C) : A * B * C := - let '(a,b) := p in (a,b,c). \ No newline at end of file + let '(a,b) := p in (a,b,c). diff --git a/base/coq/Prelude/Bool.v b/base/coq/Prelude/Bool.v index 98416186..f697f0c9 100644 --- a/base/coq/Prelude/Bool.v +++ b/base/coq/Prelude/Bool.v @@ -39,4 +39,4 @@ Instance ShareableArgsBool (Shape : Type) (Pos : Shape -> Type) : ShareableArgs Shape Pos (Bool Shape Pos) := { shareArgs := pure - }. \ No newline at end of file + }. diff --git a/base/coq/Prelude/Integer.v b/base/coq/Prelude/Integer.v index f81498e2..dd4c7409 100644 --- a/base/coq/Prelude/Integer.v +++ b/base/coq/Prelude/Integer.v @@ -98,7 +98,7 @@ End SecInteger. (* Normalform instance for Integer *) -Instance NormalformInteger (Shape : Type) (Pos : Shape -> Type) +Instance NormalformInteger (Shape : Type) (Pos : Shape -> Type) : Normalform Shape Pos (Integer Shape Pos) (Integer Identity.Shape Identity.Pos) := { nf' := pure }. diff --git a/base/coq/Prelude/List.v b/base/coq/Prelude/List.v index c099eaa2..9ed68286 100644 --- a/base/coq/Prelude/List.v +++ b/base/coq/Prelude/List.v @@ -36,7 +36,7 @@ Section SecListNF. Variable Shape : Type. Variable Pos : Shape -> Type. - Variable A B : Type. + Variable A B : Type. Fixpoint nf'List `{Normalform Shape Pos A B} (l : List Shape Pos A) @@ -50,7 +50,7 @@ Section SecListNF. end. Global Instance NormalformList `{Normalform Shape Pos A B} - : Normalform Shape Pos (List Shape Pos A) + : Normalform Shape Pos (List Shape Pos A) (List Identity.Shape Identity.Pos B) := { nf' := nf'List }. @@ -71,7 +71,7 @@ Fixpoint shareArgsList `{SA : ShareableArgs Shape Pos A} := match xs with | nil => pure nil | cons fy fys => cbneed Shape Pos (@shareArgs Shape Pos A SA) fy >>= fun sy => - cbneed Shape Pos shareArgsList fys >>= fun sys => + cbneed Shape Pos shareArgsList fys >>= fun sys => pure (cons sy sys) end. diff --git a/base/coq/Prelude/Pair.v b/base/coq/Prelude/Pair.v index 7b3e2e7b..b1173720 100644 --- a/base/coq/Prelude/Pair.v +++ b/base/coq/Prelude/Pair.v @@ -17,20 +17,6 @@ Section SecPair. : Free' (Pair A B) := pure (pair_ x y). - (* First element *) - Definition fstPair {A B : Type} (fp : Free' (Pair A B)) - : Free Shape Pos A - := fp >>= fun p => match p with - | pair_ x _ => x - end. - - (* Second element *) - Definition sndPair {A B : Type} (fp : Free' (Pair A B)) - : Free Shape Pos B - := fp >>= fun p => match p with - | pair_ _ y => y - end. - End SecPair. Arguments pair_ {Shape} {Pos} {A} {B}. @@ -55,7 +41,7 @@ Section SecNFPair. Global Instance NormalformPair `{Normalform Shape Pos A C} `{Normalform Shape Pos B D} - : Normalform Shape Pos (Pair Shape Pos A B) + : Normalform Shape Pos (Pair Shape Pos A B) (Pair Identity.Shape Identity.Pos C D) := { nf' := nf'Pair }. @@ -70,6 +56,6 @@ Instance ShareableArgsPair {Shape : Type} {Pos : Shape -> Type} (A B : Type) shareArgs p := match p with | pair_ fx fy => cbneed Shape Pos (@shareArgs Shape Pos A SAA) fx >>= fun sx => cbneed Shape Pos (@shareArgs Shape Pos B SAB) fy >>= fun sy => - (pure (pair_ sx sy)) + (pure (pair_ sx sy)) end }. diff --git a/base/coq/Prelude/Unit.v b/base/coq/Prelude/Unit.v index ce2eac51..1fb3ae1d 100644 --- a/base/coq/Prelude/Unit.v +++ b/base/coq/Prelude/Unit.v @@ -30,4 +30,4 @@ Instance ShareableArgsUnit (Shape : Type) (Pos : Shape -> Type) : ShareableArgs Shape Pos (Unit Shape Pos) := { shareArgs := pure - }. \ No newline at end of file + }. From 2a7edd531158a6dc6a19d4831079bbe565f5b3eb Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Thu, 10 Sep 2020 13:08:56 +0200 Subject: [PATCH 026/120] Refactor code and remove Shape and Pos arguments from local functions #150 --- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 57 ++++++++++--------- 1 file changed, 30 insertions(+), 27 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index b9ef1cbc..ae37eda0 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -5,7 +5,7 @@ module FreeC.Backend.Coq.Converter.TypeDecl where import Control.Monad ( foldM, mapAndUnzipM, replicateM, zipWithM ) import Control.Monad.Extra ( concatMapM ) -import Data.List ( nub, partition, intercalate ) -- TODO: Remove intercalate +import Data.List ( nub, partition ) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map import Data.Maybe ( catMaybes, fromJust ) @@ -117,7 +117,7 @@ convertDataDecls :: [IR.TypeDecl] -> Converter [Coq.Sentence] convertDataDecls dataDecls = do (indBodies, extraSentences) <- mapAndUnzipM convertDataDecl dataDecls --instances <- generateInstances dataDecls - instances <- generateAllInstances dataDecls + instances <- generateTypeclassInstances dataDecls return (Coq.comment ("Data type declarations for " ++ showPretty (map IR.typeDeclName dataDecls)) @@ -310,8 +310,8 @@ convertDataDecl (IR.TypeSynDecl _ _ _ _) -- In this case, a type @T'@ is considered indirectly recursive if it -- contains any of the types @T1, ..., Tn@. -- Arguments of type @Ti@ can be treated like directly recursive arguments. -generateAllInstances :: [IR.TypeDecl] -> Converter [Coq.Sentence] -generateAllInstances dataDecls = do +generateTypeclassInstances :: [IR.TypeDecl] -> Converter [Coq.Sentence] +generateTypeclassInstances dataDecls = do let argTypes = map (concatMap IR.conDeclFields . IR.dataDeclCons) dataDecls argTypesExpanded <- mapM (mapM expandAllTypeSynonyms) argTypes -- :: [[IR.Type]] @@ -372,7 +372,7 @@ generateAllInstances dataDecls = do = (Coq.bare functionPrefix, Coq.Qualid (fromJust (lookupType t m))) instanceName <- Coq.bare <$> nameFunction className t return - $ Coq.InstanceSentence (Coq.InstanceDefinition instanceName binders + $ Coq.InstanceSentence (Coq.InstanceDefinition instanceName (freeArgsBinders ++ binders) retType [instanceBody] Nothing) buildFunctions :: [Coq.Qualid] @@ -397,7 +397,7 @@ generateAllInstances dataDecls = do rhs <- generateBody m varName t recTypes return $ Coq.FixBody (fromJust (lookupType t m)) - (NonEmpty.fromList (binders ++ [varBinder])) Nothing (Just retType) rhs + (NonEmpty.fromList (freeArgsBinders ++ binders ++ [varBinder])) Nothing (Just retType) rhs generateBody :: TypeMap -> Coq.Qualid -> IR.Type -> [IR.Type] -> Converter Coq.Term @@ -405,7 +405,7 @@ generateAllInstances dataDecls = do = matchConstructors m varName t generateBody m varName t (recType : recTypes) = do inBody <- generateBody m varName t recTypes - var <- Coq.bare <$> freshCoqIdent "x" + var <- Coq.bare <$> freshCoqIdent freshArgPrefix letBody <- matchConstructors m var recType (binders, varBinder, retType, _) <- getBindersAndReturnTypes recType var let Just localFuncName = lookupType recType m @@ -433,7 +433,7 @@ generateAllInstances dataDecls = do conEntry <- lookupEntryOrFail NoSrcSpan IR.ValueScope conName let retType = entryReturnType conEntry let conIdent = entryIdent conEntry -- :: Qualid - conArgIdents <- freshQualids (entryArity conEntry) "fx" + conArgIdents <- freshQualids (entryArity conEntry) ("f" ++ freshArgPrefix) -- Replace all underscores with fresh variables before unification. tFreshVars <- insertFreshVariables t subst <- unifyOrFail NoSrcSpan tFreshVars retType @@ -503,7 +503,7 @@ nfBindersAndReturnType t varName = do (zipWith (\v1 v2 -> [v1, v2]) sourceVars targetVars) let varBinders = [typeBinder (sourceVars ++ targetVars) | not (null sourceVars)] - let binders = freeArgsBinders ++ varBinders ++ constraints + let binders = varBinders ++ constraints let topLevelVarBinder = Coq.typedBinder' Coq.Explicit varName sourceType let instanceRetType = Coq.app (Coq.Qualid (Coq.bare "Normalform")) (shapeAndPos ++ [sourceType, targetType]) @@ -524,14 +524,14 @@ buildNormalformValue nameMap consName = buildNormalformValue' [] buildNormalformValue' vals ((t, varName) : consVars) = case lookupType t nameMap of Just funcName -> do - x <- Coq.bare <$> freshCoqIdent "x" - nx <- Coq.bare <$> freshCoqIdent "nx" + x <- Coq.bare <$> freshCoqIdent freshArgPrefix + nx <- Coq.bare <$> freshCoqIdent ("n" ++ freshArgPrefix) rhs <- buildNormalformValue' (nx : vals) consVars let c = Coq.fun [nx] [Nothing] rhs let c'' = applyBind (Coq.app (Coq.Qualid funcName) [Coq.Qualid x]) c return $ applyBind (Coq.Qualid varName) (Coq.fun [x] [Nothing] c'') Nothing -> do - nx <- Coq.bare <$> freshCoqIdent "nx" + nx <- Coq.bare <$> freshCoqIdent ("n" ++ freshArgPrefix) rhs <- buildNormalformValue' (nx : vals) consVars let cont = Coq.fun [nx] [Nothing] rhs return @@ -599,26 +599,29 @@ applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [mx, f] applyFree :: Coq.Term -> Coq.Term applyFree a = Coq.app (Coq.Qualid Coq.Base.free) (shapeAndPos ++ [a]) --- [Shape, Pos] +-- | Shape and Pos arguments as Coq terms. shapeAndPos :: [Coq.Term] shapeAndPos = map Coq.Qualid Coq.Base.shapeAndPos --- [Identity.Shape, Identity.Pos] +-- | The shape and position function arguments for the Identity monad +-- as a Coq term. idShapeAndPos :: [Coq.Term] idShapeAndPos = map Coq.Qualid Coq.Base.idShapeAndPos --- Constructs an implicit generalized binder (~ type class constraint). --- buildConstraint name [a1 ... an] = `{name Shape Pos a1 ... an}. +-- | Constructs a type class constraint. +-- > buildConstraint name [a1 ... an] = `{name Shape Pos a1 ... an}. buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder buildConstraint ident args = Coq.Generalized Coq.Implicit (Coq.app (Coq.Qualid (Coq.bare ident)) (shapeAndPos ++ map Coq.Qualid args)) --- converts our type into a Coq type (a term) with the specified --- additional arguments (e.g. Shape and Pos) and new variables for all --- underscores. --- We can also choose the prefix for those variables. +-- | Converts a type into a Coq type (a term) with the specified +-- additional arguments (for example Shape and Pos) and new variables for all +-- underscores. +-- TODO use convertType toCoqType - :: String -> [Coq.Term] -> IR.Type -> Converter (Coq.Term, [Coq.Qualid]) + :: String -- the prefix of the fresh variables + -> [Coq.Term] -- A list of additional + -> IR.Type -> Converter (Coq.Term, [Coq.Qualid]) toCoqType varPrefix _ (IR.TypeVar _ _) = do x <- Coq.bare <$> freshCoqIdent varPrefix return (Coq.Qualid x, [x]) @@ -651,24 +654,24 @@ lookupType = flip ($) insertType :: IR.Type -> Coq.Qualid -> TypeMap -> TypeMap insertType k v m t = if k == t then Just v else m t --- Creates an entry with a unique name for each of the given types and --- inserts them into the given map. +-- | Creates an entry with a unique name for each of the given types and +-- inserts them into the given map. nameFunctionsAndInsert :: String -> TypeMap -> [IR.Type] -> Converter TypeMap nameFunctionsAndInsert prefix = foldM (nameFunctionAndInsert prefix) --- Like `nameFunctionsAndInsert`, but for a single type. +-- | Like `nameFunctionsAndInsert`, but for a single type. nameFunctionAndInsert :: String -> TypeMap -> IR.Type -> Converter TypeMap nameFunctionAndInsert prefix m t = do name <- nameFunction prefix t return (insertType t (Coq.bare name) m) --- Names a function based on a type while avoiding name clashes with other --- identifiers. +-- | Names a function based on a type while avoiding name clashes with other +-- identifiers. nameFunction :: String -> IR.Type -> Converter String nameFunction prefix t = do prettyType <- showPrettyType t freshCoqIdent (prefix ++ prettyType) --- Produces @n@ new Coq identifiers (Qualids) +-- | Produces @n@ new Coq identifiers (Qualids). freshQualids :: Int -> String -> Converter [Coq.Qualid] freshQualids n prefix = replicateM n (Coq.bare <$> freshCoqIdent prefix) From 216d8cded832af46cafafd78985ee86210cf49f5 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Thu, 10 Sep 2020 18:39:05 +0200 Subject: [PATCH 027/120] Refactor code, add documentation and fix a bug #150 The code has been restructured in a way that greatly reduces the number of maps and zips. Haddock documentation and regular comments have been added to the main functions. In addition, a bug has been fixed where unification would produce incorrect results because type synonyms in a data constructor's argument types were not expanded. --- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 293 ++++++++++++------ 1 file changed, 191 insertions(+), 102 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index ae37eda0..8eb1f23a 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -3,11 +3,11 @@ module FreeC.Backend.Coq.Converter.TypeDecl where import Control.Monad - ( foldM, mapAndUnzipM, replicateM, zipWithM ) + ( foldM, mapAndUnzipM, replicateM ) import Control.Monad.Extra ( concatMapM ) import Data.List ( nub, partition ) import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map as Map +--import qualified Data.Map.Strict as Map import Data.Maybe ( catMaybes, fromJust ) import qualified Data.Set as Set @@ -30,6 +30,8 @@ import FreeC.Monad.Converter import FreeC.Monad.Reporter import FreeC.Pretty +import Debug.Trace + ------------------------------------------------------------------------------- -- Strongly Connected Components -- ------------------------------------------------------------------------------- @@ -211,7 +213,6 @@ convertDataDecl (IR.TypeSynDecl _ _ _ _) ------------------------------------------------------------------------------- -- Instance Generation -- ------------------------------------------------------------------------------- - -- | Builds instances for all supported typeclasses. -- Currently, only a @Normalform@ instance is generated. -- @@ -312,100 +313,168 @@ convertDataDecl (IR.TypeSynDecl _ _ _ _) -- Arguments of type @Ti@ can be treated like directly recursive arguments. generateTypeclassInstances :: [IR.TypeDecl] -> Converter [Coq.Sentence] generateTypeclassInstances dataDecls = do + -- The types of the data declaration's constructors' arguments. let argTypes = map (concatMap IR.conDeclFields . IR.dataDeclCons) dataDecls + -- The same types where all type synonyms are expanded. argTypesExpanded <- mapM (mapM expandAllTypeSynonyms) argTypes -- :: [[IR.Type]] - let types = map (nub . reverse . concatMap collectSubTypes) argTypesExpanded + -- A list where all fully-applied type constructors that do not contain one of the types + -- for which we are defining instances and all type variables are replaced with + -- the same type variable (an underscore). The list is reversed so its entries are + -- in topological order. + let reducedTypes = map (nub . reverse . concatMap collectSubTypes) + argTypesExpanded + -- Like reducedTypes, but with all occurrences of the types for which we are defining + -- instances and all type variables removed from the list. + -- This leaves exactly the types with indirect recursion, with all non-recursive + -- components replaced by underscores. let recTypeList = map - (filter (\t -> not (t `elem` declTypes || IR.isTypeVar t))) types + (filter (\t -> not (t `elem` declTypes || IR.isTypeVar t))) reducedTypes + -- Construct Normalform instances. buildInstances recTypeList "nf'" "Normalform" nfBindersAndReturnType buildNormalformValue where + -- The (mutually recursive) data types for which we are defining + -- instances, converted to types. + -- declTypes :: [IR.Type] declTypes = map dataDeclToType dataDecls + -- The names of the constructors of the data types for which + -- we are defining instances. + -- conNames :: [[IR.ConName]] conNames = map IR.typeDeclQName dataDecls - -- | Builds instances for a strongly connected component of types - -- for a specific typeclass. + -- | Constructs instances of a typeclass for a set of mutually recursive + -- types. The typeclass is specified by the arguments. buildInstances - :: [[IR.Type]] -- for each dataDecl, the types contained in it with nested occurrences of one of the dataDecls - -> String -- function prefix, i.e. what functions will be called (e.g. nf' or shareArgs) - -> String -- name of the typeclass - -> (IR.Type - -> Coq.Qualid - -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term)) -- function to get class-specific binders and return types - -> (TypeMap - -> Coq.Qualid + :: + -- For each data declaration, this list contains the occurrences of + -- indirect recursion in the constructors of that data declaration. + [[IR.Type]] + -> String -- The name of the class function. + -> String -- The name of the typeclass. + -> (IR.Type -- The type for which the instance is being defined. + -> Coq.Qualid -- The name of a variable of that type. + -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term)) + -> (TypeMap -- A mapping from types to function names. + -> Coq.Qualid -- The name of a constructor. -> [(IR.Type, Coq.Qualid)] - -> Converter Coq.Term) -- how to actually build a value + -> Converter Coq.Term) -> Converter [Coq.Sentence] buildInstances recTypeList functionPrefix className getBindersAndReturnTypes buildValue = do - -- The names of the top-level functions must be defined outside of a local - -- environment to prevent any clashes with other names. + -- This map defines the name of the top-level class function for each + -- of the mutually recursive types. + -- It must be defined outside of a local environment to prevent any + -- clashes of the function names with other names. topLevelMap <- nameFunctionsAndInsert functionPrefix emptyTypeMap declTypes - -- top-level variables, one for each dataDecl - (typeLevelMaps, topLevelBindersAndReturnTypes, functionDefinitions) - <- localEnv $ do - typeLevelMaps <- mapM - (nameFunctionsAndInsert functionPrefix topLevelMap) recTypeList - topLevelVars <- freshQualids (length declTypes) "x" - topLevelBindersAndReturnTypes - <- zipWithM getBindersAndReturnTypes declTypes topLevelVars - funcDefs <- buildFunctions topLevelVars typeLevelMaps - topLevelBindersAndReturnTypes - return (typeLevelMaps, topLevelBindersAndReturnTypes, funcDefs) - -- The instance must also be defined outside of a local environment so - -- that the instance name does not clash with any other names. - instanceDefinitions <- zipWithM (uncurry buildInstance) - (zip typeLevelMaps declTypes) topLevelBindersAndReturnTypes - return (functionDefinitions : instanceDefinitions) + (fixBodies, instances) <- mapAndUnzipM + (uncurry (buildFixBodyAndInstance topLevelMap)) + (zip declTypes recTypeList) + return + $ Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) + : instances where - buildInstance :: TypeMap - -> IR.Type - -> ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) - -> Converter Coq.Sentence - buildInstance m t (binders, _, _, retType) = do - -- @nf' := nf'T@ + + + -- Constructs the class function and class instance for a single type. + buildFixBodyAndInstance + :: + -- A map to map occurrences of the top-level types to recursive + -- function calls. + TypeMap + -> IR.Type + -> [IR.Type] + -> Converter (Coq.FixBody, Coq.Sentence) + buildFixBodyAndInstance topLevelMap t recTypes = do + -- Locally visible definitions are defined in a local environment. + (fixBody, typeLevelMap, binders, instanceRetType) + <- (localEnv $ do + -- This map names necessary local functions and maps indirectly + -- recursive types to the appropriate function names. + typeLevelMap + <- nameFunctionsAndInsert functionPrefix topLevelMap recTypes + -- Name the argument of type @t@ given to the class + -- function. + topLevelVar <- Coq.bare <$> freshCoqIdent freshArgPrefix + -- Compute class-specific binders and return types. + (binders, varBinder, retType, instanceRetType) + <- getBindersAndReturnTypes t topLevelVar + -- Build the implementation of the class function. + fixBody <- makeFixBody typeLevelMap topLevelVar t + (binders ++ [varBinder]) retType recTypes + return (fixBody, typeLevelMap, binders, instanceRetType)) + -- Build the class instance for the given type. + -- The instance must be defined outside of a local environment so + -- that the instance name does not clash with any other names. + instanceDefinition <- buildInstance typeLevelMap t binders instanceRetType + return (fixBody, instanceDefinition) + + -- | Builds an instance for a specific type and typeclass. + buildInstance + :: + -- A mapping from (indirectly) recursive types to function names. + TypeMap + -- The type for which we are defining an instance. + -> IR.Type + -- The binders the instance declaration needs. + -> [Coq.Binder] + -- The return type of the instance declaration. + -> Coq.Term + -> Converter Coq.Sentence + buildInstance m t binders retType = do + -- Define the class function as the function to which the current type + -- is mapped. let instanceBody = (Coq.bare functionPrefix, Coq.Qualid (fromJust (lookupType t m))) instanceName <- Coq.bare <$> nameFunction className t return - $ Coq.InstanceSentence (Coq.InstanceDefinition instanceName (freeArgsBinders ++ binders) - retType [instanceBody] Nothing) - - buildFunctions :: [Coq.Qualid] - -> [TypeMap] - -> [([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term)] - -> Converter Coq.Sentence - buildFunctions topLevelVars typeLevelMaps topLevelBindersAndReturnTypes = do - fixBodies <- zipWithM - (uncurry (uncurry (uncurry makeFixBody))) -- I don't like this... - (zip (zip (zip typeLevelMaps topLevelVars) declTypes) - topLevelBindersAndReturnTypes) recTypeList - return - $ Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) - - makeFixBody :: TypeMap - -> Coq.Qualid - -> IR.Type - -> ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) - -> [IR.Type] - -> Converter Coq.FixBody - makeFixBody m varName t (binders, varBinder, retType, _) recTypes = do + $ Coq.InstanceSentence + (Coq.InstanceDefinition instanceName (freeArgsBinders ++ binders) + retType [instanceBody] Nothing) + + -- | Generates the implementation of a class function for the given type. + makeFixBody + -- A mapping from (indirectly) recursive types to function names. + :: TypeMap + -- The identifier of the argument the class function is applied to. + -> Coq.Qualid + -- The type for which we are defining an instance. + -> IR.Type + -- The binders needed for the class function implementation. + -> [Coq.Binder] + -- The return type of the class function. + -> Coq.Term + -- The list of indirectly recursive types that occur as arguments + -- in the given type in topological order. + -> [IR.Type] + -> Converter Coq.FixBody + makeFixBody m varName t binders retType recTypes = do rhs <- generateBody m varName t recTypes return $ Coq.FixBody (fromJust (lookupType t m)) - (NonEmpty.fromList (freeArgsBinders ++ binders ++ [varBinder])) Nothing (Just retType) rhs + (NonEmpty.fromList (freeArgsBinders ++ binders)) Nothing (Just retType) + rhs + -- | Creates the function body for a class function by creating local + -- functions for all indirectly recursive types. generateBody :: TypeMap -> Coq.Qualid -> IR.Type -> [IR.Type] -> Converter Coq.Term + -- If there are no indirectly recursive types, match on the constructors of + -- the original type. generateBody m varName t [] = matchConstructors m varName t + -- For each indirectly recursive type, create a local function as a + -- @let fix@ declaration and generate the definition of the class function + -- for that type. + -- This local declaration is wrapped around all remaining declarations and + -- is therefore visible when defining them. generateBody m varName t (recType : recTypes) = do inBody <- generateBody m varName t recTypes var <- Coq.bare <$> freshCoqIdent freshArgPrefix + -- Create the body of the local function by matching on the type's + -- constructors. letBody <- matchConstructors m var recType (binders, varBinder, retType, _) <- getBindersAndReturnTypes recType var let Just localFuncName = lookupType recType m @@ -415,6 +484,7 @@ generateTypeclassInstances dataDecls = do (NonEmpty.fromList (binders ++ [varBinder])) Nothing (Just retType) letBody))) inBody + -- | Matches on the constructors of a type. matchConstructors :: TypeMap -> Coq.Qualid -> IR.Type -> Converter Coq.Term matchConstructors m varName t = do let Just conName = IR.getTypeConName t @@ -422,31 +492,35 @@ generateTypeclassInstances dataDecls = do equations <- mapM (buildEquation m t) (entryConsNames entry) return $ Coq.match (Coq.Qualid varName) equations - -- type: type expression for unification - -- conName : data constructor name of type - buildEquation - :: TypeMap - -> IR.Type - -> IR.ConName - -> Converter Coq.Equation + -- | Creates a match equation on a given data constructor with a + -- class-specific right-hand side. + buildEquation :: TypeMap -> IR.Type -> IR.ConName -> Converter Coq.Equation buildEquation m t conName = do conEntry <- lookupEntryOrFail NoSrcSpan IR.ValueScope conName - let retType = entryReturnType conEntry - let conIdent = entryIdent conEntry -- :: Qualid + retType <- expandAllTypeSynonyms (entryReturnType conEntry) + -- Get the Coq name of the constructor. + let conIdent = trace ("Con name: " ++ show conName ++ ", RetType : " ++ showPretty retType ++", t : " ++ showPretty t) $ entryIdent conEntry + -- Generate fresh variables for the constructor's parameters. conArgIdents <- freshQualids (entryArity conEntry) ("f" ++ freshArgPrefix) -- Replace all underscores with fresh variables before unification. tFreshVars <- insertFreshVariables t subst <- unifyOrFail NoSrcSpan tFreshVars retType - let modArgTypes = map (stripType . applySubst subst) - (entryArgTypes conEntry) - let lhs = Coq.ArgsPat conIdent (map Coq.QualidPat conArgIdents) + -- Find out the type of each constructor argument by unifying its return + -- type with the given type expression and applying the resulting + -- substitution to each constructor argument's type. + -- Then convert all irrelevant components into underscores again so the + -- type can be looked up in the type map. + expandedArgTypes <- mapM expandAllTypeSynonyms (entryArgTypes conEntry) + let modArgTypes = map (stripType . applySubst subst) expandedArgTypes + let lhs = Coq.ArgsPat conIdent (map Coq.QualidPat conArgIdents) + -- Build the right-hand side of the equation by applying the + -- class-specific function buildValue. rhs <- buildValue m conIdent (zip modArgTypes conArgIdents) return $ Coq.equation lhs rhs ----------------------------------------------------------------------------- -- Type Analysis -- ----------------------------------------------------------------------------- - -- This function collects all fully-applied type constructors -- of arity at least 1 (including their arguments) that occur in the given type. -- All arguments that do not contain occurrences of the types for which @@ -487,9 +561,7 @@ generateTypeclassInstances dataDecls = do ------------------------------------------------------------------------------- -- Typeclasses -- ------------------------------------------------------------------------------- - ------- Functions for building Normalform instances ------- - -- regular binders, top-level variable binder, return type of function belonging to type, -- type of instance. nfBindersAndReturnType @@ -513,36 +585,55 @@ nfBindersAndReturnType t varName = do -- | Builds a normalized @Free@ value for the given constructor -- and constructor parameters. buildNormalformValue - :: TypeMap -> Coq.Qualid -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term + :: TypeMap -- a map to associate types with the appropriate functions to call. + -> Coq.Qualid -- the name of the constructor used to build the value. + -> [(IR.Type, Coq.Qualid) + ] --the types and names of the constructor's parameters + -> Converter Coq.Term buildNormalformValue nameMap consName = buildNormalformValue' [] where + -- | Like 'buildNormalformValue', but with an additional parameter to accumulate + -- bound variables. buildNormalformValue' :: [Coq.Qualid] -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term - buildNormalformValue' vals [] = do - args <- mapM (generatePure . Coq.Qualid) (reverse vals) + + -- If all components have been normalized, apply the constructor to + -- the normalized components. + buildNormalformValue' boundVars [] = do + args <- mapM (generatePure . Coq.Qualid) (reverse boundVars) generatePure (Coq.app (Coq.Qualid consName) args) - buildNormalformValue' vals ((t, varName) : consVars) - = case lookupType t nameMap of + -- For each component, apply the appropriate function, bind the + -- result and do the remaining computation. + buildNormalformValue' boundVars ((t, varName) : consVars) + = trace (show varName ++ " :: " ++ showPretty t ++ "\n") $ case lookupType t nameMap of + -- For recursive or indirectly recursive calls, the type map + -- returns the name of the appropriate function to call. Just funcName -> do + -- Because the functions work on bare values, the component + -- must be bound (to a fresh variable). x <- Coq.bare <$> freshCoqIdent freshArgPrefix + -- The result of the normalization will also be bound to a fresh variable. nx <- Coq.bare <$> freshCoqIdent ("n" ++ freshArgPrefix) - rhs <- buildNormalformValue' (nx : vals) consVars + -- Do the rest of the computation with the added bound result. + rhs <- buildNormalformValue' (nx : boundVars) consVars + -- Construct the actual bindings and return the result. let c = Coq.fun [nx] [Nothing] rhs - let c'' = applyBind (Coq.app (Coq.Qualid funcName) [Coq.Qualid x]) c - return $ applyBind (Coq.Qualid varName) (Coq.fun [x] [Nothing] c'') + let c' = applyBind (Coq.app (Coq.Qualid funcName) [Coq.Qualid x]) c + return $ applyBind (Coq.Qualid varName) (Coq.fun [x] [Nothing] c') + -- If there is no entry in the type map, we can assume that an instance + -- already exists. Therefore, we apply @nf@ to the component to receive + -- a normalized value. Nothing -> do nx <- Coq.bare <$> freshCoqIdent ("n" ++ freshArgPrefix) - rhs <- buildNormalformValue' (nx : vals) consVars - let cont = Coq.fun [nx] [Nothing] rhs + rhs <- buildNormalformValue' (nx : boundVars) consVars + let c = Coq.fun [nx] [Nothing] rhs return $ applyBind - (Coq.app (Coq.Qualid (Coq.bare "nf")) [Coq.Qualid varName]) cont - + (Coq.app (Coq.Qualid (Coq.bare "nf")) [Coq.Qualid varName]) c ------------------------------------------------------------------------------- -- Helper functions -- ------------------------------------------------------------------------------- - -- Like showPretty, but uses the Coq identifiers of the type and its components. showPrettyType :: IR.Type -> Converter String @@ -566,8 +657,7 @@ dataDeclToType :: IR.TypeDecl -> IR.Type dataDeclToType dataDecl = IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) (replicate (length (IR.typeDeclArgs dataDecl)) (IR.TypeVar NoSrcSpan "_")) --- Replaces all variables ("don't care" values) with --- fresh variables. +-- Replaces all variables in a type with fresh variables. insertFreshVariables :: IR.Type -> Converter IR.Type insertFreshVariables (IR.TypeVar srcSpan _) = do freshVar <- freshHaskellIdent freshArgPrefix @@ -576,15 +666,13 @@ insertFreshVariables (IR.TypeApp srcSpan l r) = do lFresh <- insertFreshVariables l rFresh <- insertFreshVariables r return (IR.TypeApp srcSpan lFresh rFresh) --- Type constructors are returned as-is. --- Function types should not occur, but are also simply returned. +-- Type constructors and function types are returned as-is. insertFreshVariables t = return t -- Binders for (implicit) Shape and Pos arguments. -- freeArgsBinders = [ {Shape : Type}, {Pos : Shape -> Type} ] freeArgsBinders :: [Coq.Binder] -freeArgsBinders = map (uncurry (Coq.typedBinder' Coq.Implicit)) - Coq.Base.freeArgs +freeArgsBinders = genericArgDecls Coq.Implicit -- Shortcut for the construction of an implicit binder for type variables. -- typeBinder [a1, ..., an] = {a1 ... an : Type} @@ -617,11 +705,12 @@ buildConstraint ident args = Coq.Generalized Coq.Implicit -- | Converts a type into a Coq type (a term) with the specified -- additional arguments (for example Shape and Pos) and new variables for all -- underscores. --- TODO use convertType -toCoqType - :: String -- the prefix of the fresh variables - -> [Coq.Term] -- A list of additional - -> IR.Type -> Converter (Coq.Term, [Coq.Qualid]) +-- Similar to convertType, but does not necessarily apply the type constructor +-- to Shape and Pos. +toCoqType :: String -- the prefix of the fresh variables + -> [Coq.Term] -- A list of additional + -> IR.Type + -> Converter (Coq.Term, [Coq.Qualid]) toCoqType varPrefix _ (IR.TypeVar _ _) = do x <- Coq.bare <$> freshCoqIdent varPrefix return (Coq.Qualid x, [x]) From 274127c76d753e1888ee07af7341a5bc7293bbc7 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Thu, 10 Sep 2020 19:12:26 +0200 Subject: [PATCH 028/120] Use Map for type map #150 The map mapping types to function names is now defined using a predefined map. For that reason, Ord instances had to be added to Type and SrcSpan. --- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 196 ++++++++---------- src/lib/FreeC/IR/SrcSpan.hs | 2 +- src/lib/FreeC/IR/Syntax/Type.hs | 2 +- 3 files changed, 86 insertions(+), 114 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 8eb1f23a..4ee44bbf 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -7,7 +7,7 @@ import Control.Monad import Control.Monad.Extra ( concatMapM ) import Data.List ( nub, partition ) import qualified Data.List.NonEmpty as NonEmpty ---import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Map import Data.Maybe ( catMaybes, fromJust ) import qualified Data.Set as Set @@ -30,8 +30,6 @@ import FreeC.Monad.Converter import FreeC.Monad.Reporter import FreeC.Pretty -import Debug.Trace - ------------------------------------------------------------------------------- -- Strongly Connected Components -- ------------------------------------------------------------------------------- @@ -102,6 +100,9 @@ convertTypeSynDecl (IR.DataDecl _ _ _ _) ------------------------------------------------------------------------------- -- Data type declarations -- ------------------------------------------------------------------------------- +-- | Type synonym for a map mapping types to function names. +type TypeMap = Map.Map IR.Type Coq.Qualid + -- | Converts multiple (mutually recursive) Haskell data type declaration -- declarations. -- @@ -331,17 +332,17 @@ generateTypeclassInstances dataDecls = do let recTypeList = map (filter (\t -> not (t `elem` declTypes || IR.isTypeVar t))) reducedTypes -- Construct Normalform instances. - buildInstances recTypeList "nf'" "Normalform" nfBindersAndReturnType - buildNormalformValue + buildInstances recTypeList normalformFuncName normalformClassName + nfBindersAndReturnType buildNormalformValue where -- The (mutually recursive) data types for which we are defining -- instances, converted to types. - -- declTypes :: [IR.Type] + declTypes :: [IR.Type] declTypes = map dataDeclToType dataDecls -- The names of the constructors of the data types for which -- we are defining instances. - -- conNames :: [[IR.ConName]] + conNames :: [IR.TypeConName] conNames = map IR.typeDeclQName dataDecls -- | Constructs instances of a typeclass for a set of mutually recursive @@ -367,8 +368,7 @@ generateTypeclassInstances dataDecls = do -- of the mutually recursive types. -- It must be defined outside of a local environment to prevent any -- clashes of the function names with other names. - topLevelMap - <- nameFunctionsAndInsert functionPrefix emptyTypeMap declTypes + topLevelMap <- nameFunctionsAndInsert functionPrefix Map.empty declTypes (fixBodies, instances) <- mapAndUnzipM (uncurry (buildFixBodyAndInstance topLevelMap)) (zip declTypes recTypeList) @@ -376,58 +376,45 @@ generateTypeclassInstances dataDecls = do $ Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) : instances where - - -- Constructs the class function and class instance for a single type. buildFixBodyAndInstance - :: - -- A map to map occurrences of the top-level types to recursive - -- function calls. - TypeMap - -> IR.Type - -> [IR.Type] - -> Converter (Coq.FixBody, Coq.Sentence) + :: + -- A map to map occurrences of the top-level types to recursive + -- function calls. + TypeMap -> IR.Type -> [IR.Type] -> Converter (Coq.FixBody, Coq.Sentence) buildFixBodyAndInstance topLevelMap t recTypes = do - -- Locally visible definitions are defined in a local environment. - (fixBody, typeLevelMap, binders, instanceRetType) - <- (localEnv $ do - -- This map names necessary local functions and maps indirectly - -- recursive types to the appropriate function names. - typeLevelMap - <- nameFunctionsAndInsert functionPrefix topLevelMap recTypes - -- Name the argument of type @t@ given to the class - -- function. - topLevelVar <- Coq.bare <$> freshCoqIdent freshArgPrefix - -- Compute class-specific binders and return types. - (binders, varBinder, retType, instanceRetType) - <- getBindersAndReturnTypes t topLevelVar - -- Build the implementation of the class function. - fixBody <- makeFixBody typeLevelMap topLevelVar t - (binders ++ [varBinder]) retType recTypes - return (fixBody, typeLevelMap, binders, instanceRetType)) - -- Build the class instance for the given type. - -- The instance must be defined outside of a local environment so - -- that the instance name does not clash with any other names. - instanceDefinition <- buildInstance typeLevelMap t binders instanceRetType - return (fixBody, instanceDefinition) + -- Locally visible definitions are defined in a local environment. + (fixBody, typeLevelMap, binders, instanceRetType) <- localEnv $ do + -- This map names necessary local functions and maps indirectly + -- recursive types to the appropriate function names. + typeLevelMap + <- nameFunctionsAndInsert functionPrefix topLevelMap recTypes + -- Name the argument of type @t@ given to the class + -- function. + topLevelVar <- Coq.bare <$> freshCoqIdent freshArgPrefix + -- Compute class-specific binders and return types. + (binders, varBinder, retType, instanceRetType) + <- getBindersAndReturnTypes t topLevelVar + -- Build the implementation of the class function. + fixBody <- makeFixBody typeLevelMap topLevelVar t + (binders ++ [varBinder]) retType recTypes + return (fixBody, typeLevelMap, binders, instanceRetType) + -- Build the class instance for the given type. + -- The instance must be defined outside of a local environment so + -- that the instance name does not clash with any other names. + instanceDefinition <- buildInstance typeLevelMap t binders instanceRetType + return (fixBody, instanceDefinition) -- | Builds an instance for a specific type and typeclass. buildInstance :: -- A mapping from (indirectly) recursive types to function names. - TypeMap - -- The type for which we are defining an instance. - -> IR.Type - -- The binders the instance declaration needs. - -> [Coq.Binder] - -- The return type of the instance declaration. - -> Coq.Term - -> Converter Coq.Sentence + TypeMap -> IR.Type -> [Coq.Binder] -> Coq.Term -> Converter Coq.Sentence buildInstance m t binders retType = do -- Define the class function as the function to which the current type -- is mapped. let instanceBody - = (Coq.bare functionPrefix, Coq.Qualid (fromJust (lookupType t m))) + = (Coq.bare functionPrefix, Coq.Qualid (fromJust (Map.lookup t m))) instanceName <- Coq.bare <$> nameFunction className t return $ Coq.InstanceSentence @@ -436,24 +423,20 @@ generateTypeclassInstances dataDecls = do -- | Generates the implementation of a class function for the given type. makeFixBody - -- A mapping from (indirectly) recursive types to function names. - :: TypeMap - -- The identifier of the argument the class function is applied to. + :: + -- A mapping from (indirectly or directly) recursive types to the name + -- of the function that handles arguments of those types. + TypeMap -> Coq.Qualid - -- The type for which we are defining an instance. - -> IR.Type - -- The binders needed for the class function implementation. - -> [Coq.Binder] - -- The return type of the class function. - -> Coq.Term - -- The list of indirectly recursive types that occur as arguments - -- in the given type in topological order. - -> [IR.Type] - -> Converter Coq.FixBody + -> IR.Type + -> [Coq.Binder] + -> Coq.Term + -> [IR.Type] + -> Converter Coq.FixBody makeFixBody m varName t binders retType recTypes = do rhs <- generateBody m varName t recTypes return - $ Coq.FixBody (fromJust (lookupType t m)) + $ Coq.FixBody (fromJust (Map.lookup t m)) (NonEmpty.fromList (freeArgsBinders ++ binders)) Nothing (Just retType) rhs @@ -461,6 +444,7 @@ generateTypeclassInstances dataDecls = do -- functions for all indirectly recursive types. generateBody :: TypeMap -> Coq.Qualid -> IR.Type -> [IR.Type] -> Converter Coq.Term + -- If there are no indirectly recursive types, match on the constructors of -- the original type. generateBody m varName t [] @@ -477,7 +461,7 @@ generateTypeclassInstances dataDecls = do -- constructors. letBody <- matchConstructors m var recType (binders, varBinder, retType, _) <- getBindersAndReturnTypes recType var - let Just localFuncName = lookupType recType m + let Just localFuncName = Map.lookup recType m return $ Coq.Let localFuncName [] Nothing (Coq.Fix (Coq.FixOne (Coq.FixBody localFuncName @@ -499,7 +483,7 @@ generateTypeclassInstances dataDecls = do conEntry <- lookupEntryOrFail NoSrcSpan IR.ValueScope conName retType <- expandAllTypeSynonyms (entryReturnType conEntry) -- Get the Coq name of the constructor. - let conIdent = trace ("Con name: " ++ show conName ++ ", RetType : " ++ showPretty retType ++", t : " ++ showPretty t) $ entryIdent conEntry + let conIdent = entryIdent conEntry -- Generate fresh variables for the constructor's parameters. conArgIdents <- freshQualids (entryArity conEntry) ("f" ++ freshArgPrefix) -- Replace all underscores with fresh variables before unification. @@ -512,7 +496,7 @@ generateTypeclassInstances dataDecls = do -- type can be looked up in the type map. expandedArgTypes <- mapM expandAllTypeSynonyms (entryArgTypes conEntry) let modArgTypes = map (stripType . applySubst subst) expandedArgTypes - let lhs = Coq.ArgsPat conIdent (map Coq.QualidPat conArgIdents) + let lhs = Coq.ArgsPat conIdent (map Coq.QualidPat conArgIdents) -- Build the right-hand side of the equation by applying the -- class-specific function buildValue. rhs <- buildValue m conIdent (zip modArgTypes conArgIdents) @@ -521,6 +505,24 @@ generateTypeclassInstances dataDecls = do ----------------------------------------------------------------------------- -- Type Analysis -- ----------------------------------------------------------------------------- + -- | Creates an entry with a unique name for each of the given types and + -- inserts them into the given map. + nameFunctionsAndInsert :: String -> TypeMap -> [IR.Type] -> Converter TypeMap + nameFunctionsAndInsert prefix = foldM (nameFunctionAndInsert prefix) + + -- | Like `nameFunctionsAndInsert`, but for a single type. + nameFunctionAndInsert :: String -> TypeMap -> IR.Type -> Converter TypeMap + nameFunctionAndInsert prefix m t = do + name <- nameFunction prefix t + return (Map.insert t (Coq.bare name) m) + + -- | Names a function based on a type expression while avoiding name clashes + -- with other identifiers. + nameFunction :: String -> IR.Type -> Converter String + nameFunction prefix t = do + prettyType <- showPrettyType t + freshCoqIdent (prefix ++ prettyType) + -- This function collects all fully-applied type constructors -- of arity at least 1 (including their arguments) that occur in the given type. -- All arguments that do not contain occurrences of the types for which @@ -559,11 +561,17 @@ generateTypeclassInstances dataDecls = do stripType' _ _ = IR.TypeVar NoSrcSpan "_" ------------------------------------------------------------------------------- --- Typeclasses -- +-- Typeclass-specific Functions -- +------------------------------------------------------------------------------- +------------------------------------------------------------------------------- +-- Functions to produce Normalform instances -- ------------------------------------------------------------------------------- -------- Functions for building Normalform instances ------- --- regular binders, top-level variable binder, return type of function belonging to type, --- type of instance. +normalformClassName :: String +normalformClassName = "Normalform" + +normalformFuncName :: String +normalformFuncName = "nf'" + nfBindersAndReturnType :: IR.Type -> Coq.Qualid @@ -571,13 +579,13 @@ nfBindersAndReturnType nfBindersAndReturnType t varName = do (sourceType, sourceVars) <- toCoqType "a" shapeAndPos t (targetType, targetVars) <- toCoqType "b" idShapeAndPos t - let constraints = map (buildConstraint "Normalform") + let constraints = map (buildConstraint normalformClassName) (zipWith (\v1 v2 -> [v1, v2]) sourceVars targetVars) let varBinders = [typeBinder (sourceVars ++ targetVars) | not (null sourceVars)] let binders = varBinders ++ constraints let topLevelVarBinder = Coq.typedBinder' Coq.Explicit varName sourceType - let instanceRetType = Coq.app (Coq.Qualid (Coq.bare "Normalform")) + let instanceRetType = Coq.app (Coq.Qualid (Coq.bare normalformClassName)) (shapeAndPos ++ [sourceType, targetType]) let funcRetType = applyFree targetType return (binders, topLevelVarBinder, funcRetType, instanceRetType) @@ -605,7 +613,7 @@ buildNormalformValue nameMap consName = buildNormalformValue' [] -- For each component, apply the appropriate function, bind the -- result and do the remaining computation. buildNormalformValue' boundVars ((t, varName) : consVars) - = trace (show varName ++ " :: " ++ showPretty t ++ "\n") $ case lookupType t nameMap of + = case Map.lookup t nameMap of -- For recursive or indirectly recursive calls, the type map -- returns the name of the appropriate function to call. Just funcName -> do @@ -628,8 +636,8 @@ buildNormalformValue nameMap consName = buildNormalformValue' [] rhs <- buildNormalformValue' (nx : boundVars) consVars let c = Coq.fun [nx] [Nothing] rhs return - $ applyBind - (Coq.app (Coq.Qualid (Coq.bare "nf")) [Coq.Qualid varName]) c + $ applyBind (Coq.app (Coq.Qualid (Coq.bare normalformFuncName)) + [Coq.Qualid varName]) c ------------------------------------------------------------------------------- -- Helper functions -- @@ -725,42 +733,6 @@ toCoqType _ _ (IR.FuncType _ _ _) = error "Function types should have been eliminated." ------------------------------- --- Function name map --- For each type that contains one of the types we are defining --- an instance for - directly or indirectly -, we insert an --- entry into a map that returns the name of the function we --- should call on a value of that type. --- For all types that do not have a corresponding entry, we --- can assume that an instance already exists. -type TypeMap = IR.Type -> Maybe Coq.Qualid - -emptyTypeMap :: TypeMap -emptyTypeMap = const Nothing - -lookupType :: IR.Type -> TypeMap -> Maybe Coq.Qualid -lookupType = flip ($) - -insertType :: IR.Type -> Coq.Qualid -> TypeMap -> TypeMap -insertType k v m t = if k == t then Just v else m t - --- | Creates an entry with a unique name for each of the given types and --- inserts them into the given map. -nameFunctionsAndInsert :: String -> TypeMap -> [IR.Type] -> Converter TypeMap -nameFunctionsAndInsert prefix = foldM (nameFunctionAndInsert prefix) - --- | Like `nameFunctionsAndInsert`, but for a single type. -nameFunctionAndInsert :: String -> TypeMap -> IR.Type -> Converter TypeMap -nameFunctionAndInsert prefix m t = do - name <- nameFunction prefix t - return (insertType t (Coq.bare name) m) - --- | Names a function based on a type while avoiding name clashes with other --- identifiers. -nameFunction :: String -> IR.Type -> Converter String -nameFunction prefix t = do - prettyType <- showPrettyType t - freshCoqIdent (prefix ++ prettyType) - --- | Produces @n@ new Coq identifiers (Qualids). +-- | Produces @n@ new Coq identifiers (Qualids) with the same prefix. freshQualids :: Int -> String -> Converter [Coq.Qualid] freshQualids n prefix = replicateM n (Coq.bare <$> freshCoqIdent prefix) diff --git a/src/lib/FreeC/IR/SrcSpan.hs b/src/lib/FreeC/IR/SrcSpan.hs index 85c1c0df..15fb198e 100644 --- a/src/lib/FreeC/IR/SrcSpan.hs +++ b/src/lib/FreeC/IR/SrcSpan.hs @@ -79,7 +79,7 @@ data SrcSpan | FileSpan -- ^ Points to an unknown location in the given file. { srcSpanFilename :: String -- ^ The name of the file. } - deriving ( Eq, Show ) + deriving ( Eq, Ord, Show ) ------------------------------------------------------------------------------- -- Predicates -- diff --git a/src/lib/FreeC/IR/Syntax/Type.hs b/src/lib/FreeC/IR/Syntax/Type.hs index 9cba7ebe..96391537 100644 --- a/src/lib/FreeC/IR/Syntax/Type.hs +++ b/src/lib/FreeC/IR/Syntax/Type.hs @@ -30,7 +30,7 @@ data Type , funcTypeArg :: Type , funcTypeRes :: Type } - deriving ( Eq, Show ) + deriving ( Eq, Ord, Show ) -- | Creates a type constructor application type. -- From bccdf4c757074a676e744753773c1d386ce248ee Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Thu, 10 Sep 2020 19:22:58 +0200 Subject: [PATCH 029/120] Fix refactoring-induced bug #150 --- src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 4ee44bbf..bb04b2bb 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -636,7 +636,7 @@ buildNormalformValue nameMap consName = buildNormalformValue' [] rhs <- buildNormalformValue' (nx : boundVars) consVars let c = Coq.fun [nx] [Nothing] rhs return - $ applyBind (Coq.app (Coq.Qualid (Coq.bare normalformFuncName)) + $ applyBind (Coq.app (Coq.Qualid (Coq.bare "nf")) [Coq.Qualid varName]) c ------------------------------------------------------------------------------- From 7dd0b0dab4ac366ebe511e8016d99a96dbebe749 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Fri, 11 Sep 2020 09:33:58 +0200 Subject: [PATCH 030/120] Adjust proofs in example folder #119 --- example/Proofs/ConsUnconsProofs.v | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/example/Proofs/ConsUnconsProofs.v b/example/Proofs/ConsUnconsProofs.v index 930d9355..045c12bf 100644 --- a/example/Proofs/ConsUnconsProofs.v +++ b/example/Proofs/ConsUnconsProofs.v @@ -13,7 +13,7 @@ Proof. Qed. (* The second QuickCheck property holds provably for the [Maybe] instance of [Partial]. *) -Lemma unconsE_fst_Maybe : quickCheck +Lemma unconsE_fst_Maybe : quickCheck (@prop_unconsE_fst Maybe.Shape Maybe.Pos (Maybe.Partial Maybe.Shape Maybe.Pos)). Proof. intros A fxs. @@ -28,7 +28,7 @@ Qed. (* But the second QuickCheck property doesn't hold for the [Error] instance of [Partial] as [unconsE] and [head] have different error messages on an empty list. *) -Lemma unconsE_fst_Error : not (quickCheck (@prop_unconsE_fst (Error.Shape string) Error.Pos Error.Partial)). +Lemma unconsE_fst_Error : not (quickCheck (@prop_unconsE_fst (Error.Shape string) Error.Pos (Error.Partial (Error.Shape string) Error.Pos))). Proof. intro H. specialize (H bool (Nil _ _)). @@ -39,16 +39,16 @@ Section ErrorMessages. (* To prove facts about the error messages we can write an abbreviation for an [error] with a specific message. *) - Definition EmptyListError {A : Type} := @error _ _ Error.Partial A "unconsE: empty list"%string. + Definition EmptyListError {A : Type} := @error _ _ (Error.Partial _ _) A "unconsE: empty list"%string. (* If we weren't looking for an actual [error] but for an [undefined] in haskell we could use the following definition. *) - Definition Undefined {A : Type} := @undefined _ _ Error.Partial A. + Definition Undefined {A : Type} := @undefined _ _ (Error.Partial _ _) A. (* Now we can define and prove the lemma that using [unconsE] with an empty list results in an [EmptyListError] *) Lemma nil_unconsE_empty_list_error : forall (A : Type), - @unconsE _ _ Error.Partial A (Nil _ _) = EmptyListError. + @unconsE _ _ (Error.Partial _ _) A (Nil _ _) = EmptyListError. Proof. intro A. simpl. @@ -58,7 +58,7 @@ Section ErrorMessages. (* We can also prove that using [unconsE] on an non-empty list does not cause an [EmptyListError]. *) Lemma cons_unconsE_no_empty_list_error : forall (A : Type) (fx : Free _ _ A) (fxs : Free _ _ (List _ _ A)), - unconsE _ _ Error.Partial (Cons _ _ fx fxs) <> EmptyListError. + unconsE _ _ (Error.Partial _ _) (Cons _ _ fx fxs) <> EmptyListError. Proof. intros A fx fxs. simpl. @@ -68,8 +68,8 @@ Section ErrorMessages. (* And finally we can prove that an [EmptyListError] is the only error that can occur if the argument is error-free. *) Lemma unconsE_only_empty_list_error : forall (A : Type) (l : List _ _ A), - (exists (result : Pair _ _ A (List _ _ A)), unconsE _ _ Error.Partial (NoError l) = NoError result) \/ - ( unconsE _ _ Error.Partial (NoError l) = EmptyListError). + (exists (result : Pair _ _ A (List _ _ A)), unconsE _ _ (Error.Partial _ _) (NoError _ _ l) = NoError _ _ result) \/ + ( unconsE _ _ (Error.Partial _ _) (NoError _ _ l) = EmptyListError). Proof. intros A l. destruct l as [ | fx fxs ]. From 7a57f7cddaefb586a1236eb8a89026499781ce44 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Fri, 11 Sep 2020 19:50:40 +0200 Subject: [PATCH 031/120] Add support for case expressions with single variable pattern #74 --- src/lib/FreeC/Frontend/Haskell/Simplifier.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/lib/FreeC/Frontend/Haskell/Simplifier.hs b/src/lib/FreeC/Frontend/Haskell/Simplifier.hs index e35ef006..ba51d798 100644 --- a/src/lib/FreeC/Frontend/Haskell/Simplifier.hs +++ b/src/lib/FreeC/Frontend/Haskell/Simplifier.hs @@ -635,11 +635,24 @@ simplifyExpr (HSE.If srcSpan e1 e2 e3) = do e2' <- simplifyExpr e2 e3' <- simplifyExpr e3 return (IR.If srcSpan e1' e2' e3' Nothing) +-- Case expressions with a single variable pattern are sometimes generated by +-- the pattern matching compiler. They are translated to a lambda abstraction +-- that is immediately applied to the scrutinee. +simplifyExpr (HSE.Case caseSrcSpan scrutinee + [ HSE.Alt altSrcSpan (HSE.PVar patSrcSpan (HSE.Ident _ ident)) + (HSE.UnGuardedRhs _ expr) Nothing + ]) = do + scrutinee' <- simplifyExpr scrutinee + expr' <- simplifyExpr expr + let pat' = IR.VarPat patSrcSpan ident Nothing False + lambda' = IR.Lambda altSrcSpan [pat'] expr' Nothing + return (IR.App caseSrcSpan lambda' scrutinee' Nothing) -- Case expressions. simplifyExpr (HSE.Case srcSpan expr alts) = do expr' <- simplifyExpr expr alts' <- mapM simplifyAlt alts return (IR.Case srcSpan expr' alts' Nothing) +-- Let expressions. simplifyExpr (HSE.Let srcSpan binds expr) = do expr' <- simplifyExpr expr binds' <- simplifyBinds binds From 9b717060f1ad8aaec6b8ef17a81bb43d7ef26dea Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Fri, 11 Sep 2020 19:51:24 +0200 Subject: [PATCH 032/120] Add first tests for Haskell to IR translation #74 --- free-compiler.cabal | 2 + .../FreeC/Frontend/Haskell/SimplifierTests.hs | 44 +++++++++++++++++++ src/test/FreeC/Frontend/Haskell/Tests.hs | 11 +++++ src/test/FreeC/Frontend/IR/ParserTests.hs | 1 + src/test/Spec.hs | 2 + 5 files changed, 60 insertions(+) create mode 100644 src/test/FreeC/Frontend/Haskell/SimplifierTests.hs create mode 100644 src/test/FreeC/Frontend/Haskell/Tests.hs diff --git a/free-compiler.cabal b/free-compiler.cabal index 4c6dc913..2634057f 100644 --- a/free-compiler.cabal +++ b/free-compiler.cabal @@ -236,6 +236,8 @@ test-suite freec-unit-tests , FreeC.EnvironmentTests , FreeC.Environment.FreshTests , FreeC.Environment.RenamerTests + , FreeC.Frontend.Haskell.SimplifierTests + , FreeC.Frontend.Haskell.Tests , FreeC.Frontend.IR.ParserTests , FreeC.Frontend.IR.ScannerTests , FreeC.Frontend.IR.Tests diff --git a/src/test/FreeC/Frontend/Haskell/SimplifierTests.hs b/src/test/FreeC/Frontend/Haskell/SimplifierTests.hs new file mode 100644 index 00000000..1b35338d --- /dev/null +++ b/src/test/FreeC/Frontend/Haskell/SimplifierTests.hs @@ -0,0 +1,44 @@ +-- | This module contains tests for "FreeC.Frontend.Haskell.Simplifier". +module FreeC.Frontend.Haskell.SimplifierTests (testSimplifier) where + +import Control.Monad ( (>=>) ) +import Test.Hspec + +import qualified FreeC.IR.Syntax as IR +import FreeC.Frontend.Haskell.Parser +import FreeC.Frontend.Haskell.Simplifier +import FreeC.Monad.Class.Testable +import FreeC.Test.Expectations +import FreeC.Test.Parser +import FreeC.IR.SrcSpan + +------------------------------------------------------------------------------- +-- Utility functions -- +------------------------------------------------------------------------------- + +-- | Parses a Haskell expression and converts it to IR. +parseAndSimplifyExpr :: String -> Simplifier IR.Expr +parseAndSimplifyExpr = (parseHaskell . mkSrcFile "") >=> simplifyExpr + +-- | Parses the given Haskell and IR expressions, converts the Haskell +-- expression to IR . +shouldSimplifyExpr :: String -> String -> Simplifier Expectation +shouldSimplifyExpr input expectedOutput = do + output <- parseAndSimplifyExpr input + expectedOutput' <- parseTestExpr expectedOutput + return (output `shouldBeSimilarTo` expectedOutput') + +------------------------------------------------------------------------------- +-- Tests -- +------------------------------------------------------------------------------- + +-- | Test group for "FreeC.Frontend.Haskell.Simplifier" tests. +testSimplifier :: Spec +testSimplifier = describe "FreeC.Frontend.Haskell.Simplifier" $ do + testSimplifyExpr + +-- | Test group for 'simplifyExpr' tests. +testSimplifyExpr :: Spec +testSimplifyExpr = context "simplifyExpr" $ do + it "simplifies single variable pattern case expression to lambda abstractions" $ shouldSucceedWith $ do + "case e of { x -> e' }" `shouldSimplifyExpr` "(\\x -> e') e" diff --git a/src/test/FreeC/Frontend/Haskell/Tests.hs b/src/test/FreeC/Frontend/Haskell/Tests.hs new file mode 100644 index 00000000..37093521 --- /dev/null +++ b/src/test/FreeC/Frontend/Haskell/Tests.hs @@ -0,0 +1,11 @@ +-- | Test group for tests of modules below @FreeC.Frontend.Haskell@. +module FreeC.Frontend.Haskell.Tests ( testHaskellFrontend ) where + +import Test.Hspec + +import FreeC.Frontend.Haskell.SimplifierTests + +-- | Test group for tests of modules below @FreeC.Frontend.Haskell@. +testHaskellFrontend :: Spec +testHaskellFrontend = do + testSimplifier diff --git a/src/test/FreeC/Frontend/IR/ParserTests.hs b/src/test/FreeC/Frontend/IR/ParserTests.hs index 88a799e0..2d70b052 100644 --- a/src/test/FreeC/Frontend/IR/ParserTests.hs +++ b/src/test/FreeC/Frontend/IR/ParserTests.hs @@ -1,3 +1,4 @@ +-- | This module contains tests for "FreeC.Frontend.IR.Parser". module FreeC.Frontend.IR.ParserTests where import Test.Hspec hiding ( shouldReturn ) diff --git a/src/test/Spec.hs b/src/test/Spec.hs index 86bf1d1d..05cb9c3b 100644 --- a/src/test/Spec.hs +++ b/src/test/Spec.hs @@ -6,6 +6,7 @@ import Test.Hspec import FreeC.Backend.Agda.Tests import FreeC.Backend.Coq.Tests import FreeC.EnvironmentTests +import FreeC.Frontend.Haskell.Tests import FreeC.Frontend.IR.Tests import FreeC.IR.Tests import FreeC.Monad.ReporterTests @@ -15,6 +16,7 @@ import FreeC.PipelineTests main :: IO () main = hspec $ do testEnvironment + testHaskellFrontend testIR testIRFrontend testAgdaBackend From 759705835ead8ac111dcb1e3c5b985b5ee81839a Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Fri, 11 Sep 2020 20:45:40 +0200 Subject: [PATCH 033/120] Add pass for processing pragmas #70 --- free-compiler.cabal | 12 +++--- .../FreeC/Backend/Agda/Converter/Module.hs | 7 +--- src/lib/FreeC/Backend/Coq/Converter/Module.hs | 3 -- .../{IR/Pragma.hs => Pass/PragmaPass.hs} | 40 +++++++++++++++++-- src/lib/FreeC/Pipeline.hs | 2 + 5 files changed, 47 insertions(+), 17 deletions(-) rename src/lib/FreeC/{IR/Pragma.hs => Pass/PragmaPass.hs} (60%) diff --git a/free-compiler.cabal b/free-compiler.cabal index 4c6dc913..a3eed89a 100644 --- a/free-compiler.cabal +++ b/free-compiler.cabal @@ -134,14 +134,10 @@ library freec-internal , FreeC.Frontend.IR.PragmaParser , FreeC.Frontend.IR.Scanner , FreeC.Frontend.IR.Token - , FreeC.Monad.Converter - , FreeC.Monad.Class.Hoistable - , FreeC.Monad.Reporter , FreeC.IR.Base.Prelude , FreeC.IR.Base.Test.QuickCheck , FreeC.IR.DependencyGraph , FreeC.IR.Inlining - , FreeC.IR.Pragma , FreeC.IR.Reference , FreeC.IR.Similar , FreeC.IR.SrcSpan @@ -168,6 +164,9 @@ library freec-internal , FreeC.LiftedIR.Syntax.Expr , FreeC.LiftedIR.Syntax.Name , FreeC.LiftedIR.Syntax.Type + , FreeC.Monad.Class.Hoistable + , FreeC.Monad.Converter + , FreeC.Monad.Reporter , FreeC.Pass , FreeC.Pass.CompletePatternPass , FreeC.Pass.DefineDeclPass @@ -178,10 +177,11 @@ library freec-internal , FreeC.Pass.ImportPass , FreeC.Pass.KindCheckPass , FreeC.Pass.PartialityAnalysisPass - , FreeC.Pass.TypeInferencePass - , FreeC.Pass.TypeSignaturePass + , FreeC.Pass.PragmaPass , FreeC.Pass.QualifierPass , FreeC.Pass.ResolverPass + , FreeC.Pass.TypeInferencePass + , FreeC.Pass.TypeSignaturePass , FreeC.Pipeline , FreeC.Pretty , FreeC.Util.Config diff --git a/src/lib/FreeC/Backend/Agda/Converter/Module.hs b/src/lib/FreeC/Backend/Agda/Converter/Module.hs index 8b8380cf..51d79ad9 100644 --- a/src/lib/FreeC/Backend/Agda/Converter/Module.hs +++ b/src/lib/FreeC/Backend/Agda/Converter/Module.hs @@ -13,17 +13,14 @@ import FreeC.Environment ( lookupAvailableModule ) import FreeC.Environment.ModuleInterface ( interfaceAgdaLibName ) import FreeC.IR.DependencyGraph ( groupFuncDecls, groupTypeDecls ) -import FreeC.IR.Pragma import qualified FreeC.IR.Syntax as IR import FreeC.Monad.Converter -- | Converts an IR module to an Agda declaration. convertModule :: IR.Module -> Converter Agda.Declaration convertModule (IR.Module _ name importDecls typeDecls _ modPragmas funcDecls) - = do - mapM_ (addDecArgPragma funcDecls) modPragmas - Agda.moduleDecl (convertModName name) - <$> getAp (importDecls' <> typeDecls' <> funcDecls') + = Agda.moduleDecl (convertModName name) + <$> getAp (importDecls' <> typeDecls' <> funcDecls') where importDecls' = Ap $ convertImportDecls importDecls diff --git a/src/lib/FreeC/Backend/Coq/Converter/Module.hs b/src/lib/FreeC/Backend/Coq/Converter/Module.hs index 80b00368..a3cb8d1d 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/Module.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/Module.hs @@ -10,7 +10,6 @@ import qualified FreeC.Backend.Coq.Syntax as Coq import FreeC.Environment import FreeC.Environment.ModuleInterface import FreeC.IR.DependencyGraph -import FreeC.IR.Pragma import qualified FreeC.IR.Syntax as IR import FreeC.Monad.Converter import FreeC.Pretty @@ -22,8 +21,6 @@ import FreeC.Pretty convertModule :: IR.Module -> Converter [Coq.Sentence] convertModule haskellAst = do imports' <- convertImportDecls (IR.modImports haskellAst) - mapM_ (addDecArgPragma (IR.modFuncDecls haskellAst)) - (IR.modPragmas haskellAst) decls' <- convertDecls (IR.modTypeDecls haskellAst) (IR.modFuncDecls haskellAst) return (Coq.comment ("module " ++ IR.modName haskellAst) : imports' ++ decls') diff --git a/src/lib/FreeC/IR/Pragma.hs b/src/lib/FreeC/Pass/PragmaPass.hs similarity index 60% rename from src/lib/FreeC/IR/Pragma.hs rename to src/lib/FreeC/Pass/PragmaPass.hs index c10460ca..00f1b089 100644 --- a/src/lib/FreeC/IR/Pragma.hs +++ b/src/lib/FreeC/Pass/PragmaPass.hs @@ -1,6 +1,33 @@ --- | This module contains a function for processing the decreasing argument --- pragma. -module FreeC.IR.Pragma where +-- | This module contains a compiler pass that processes pragmas. +-- +-- = Specification +-- +-- == Preconditions +-- +-- There are no special requirements. +-- +-- == Translation +-- +-- * If there is a pragma of the form @{-# FreeC f DECREASES ON xᵢ #-}@ +-- or @{-# FreeC f DECREASES ON ARGUMENT i #-}@ and a declaration +-- @f x₁ … xᵢ … xₙ = e@, the index @i - 1@ and identifier @xᵢ@ are +-- inserted into the environment as the decreasing argument of @f@. +-- +-- == Postconditions +-- +-- * There is an entry for all explicitly annotated decreasing arguments +-- in the environment. +-- +-- == Error Cases +-- +-- * If there is a pragmaof the form @{-# FreeC f DECREASES ON xᵢ #-}@ or +-- @{-# FreeC f DECREASES ON ARGUMENT i #-}@, but there is no such +-- function declaration or the function does not have an argument with +-- the specified name or at the specified position, a fatal error is +-- reported. + + +module FreeC.Pass.PragmaPass ( pragmaPass ) where import Data.List ( find, findIndex ) @@ -8,8 +35,15 @@ import FreeC.Environment import qualified FreeC.IR.Syntax as IR import FreeC.Monad.Converter import FreeC.Monad.Reporter +import FreeC.Pass import FreeC.Pretty +-- | A pass that processes the pragmas of a module. +pragmaPass :: Pass IR.Module IR.Module +pragmaPass ast = do + mapM_ (addDecArgPragma (IR.modFuncDecls ast)) (IR.modPragmas ast) + return ast + -- | Inserts the decreasing argument's index annotated by the given pragma -- into the environment. -- diff --git a/src/lib/FreeC/Pipeline.hs b/src/lib/FreeC/Pipeline.hs index f3d7ebf1..fb1345f6 100644 --- a/src/lib/FreeC/Pipeline.hs +++ b/src/lib/FreeC/Pipeline.hs @@ -22,6 +22,7 @@ import FreeC.Pass.KindCheckPass import FreeC.Pass.PartialityAnalysisPass import FreeC.Pass.QualifierPass import FreeC.Pass.ResolverPass +import FreeC.Pass.PragmaPass import FreeC.Pass.TypeInferencePass import FreeC.Pass.TypeSignaturePass @@ -34,6 +35,7 @@ pipeline = implicitPreludePass >=> dependencyAnalysisPass defineTypeDeclsPass >=> kindCheckPass >=> typeSignaturePass + >=> pragmaPass >=> dependencyAnalysisPass (typeInferencePass >=> defineFuncDeclsPass >=> partialityAnalysisPass) >=> completePatternPass From 0c04cb4ef6c02936c341f7dadb5be3ea0e281500 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Fri, 11 Sep 2020 22:36:54 +0200 Subject: [PATCH 034/120] Add type class for nodes with declaration name #158 --- src/lib/FreeC/IR/Syntax/Expr.hs | 11 ++++++++++- src/lib/FreeC/IR/Syntax/FuncDecl.hs | 8 ++++++-- src/lib/FreeC/IR/Syntax/Name.hs | 13 +++++++++++++ src/lib/FreeC/IR/Syntax/TypeDecl.hs | 18 +++++++++++++----- 4 files changed, 42 insertions(+), 8 deletions(-) diff --git a/src/lib/FreeC/IR/Syntax/Expr.hs b/src/lib/FreeC/IR/Syntax/Expr.hs index a4328a8e..836c5f7d 100644 --- a/src/lib/FreeC/IR/Syntax/Expr.hs +++ b/src/lib/FreeC/IR/Syntax/Expr.hs @@ -310,6 +310,11 @@ data VarPat = VarPat { varPatSrcSpan :: SrcSpan } deriving ( Eq, Show ) +-- | Instance to get the name of a @let@-binding.. +instance HasDeclIdent VarPat where + declIdent varPat = DeclIdent (varPatSrcSpan varPat) + (UnQual (Ident (varPatIdent varPat))) + -- | Gets the name of the given variable pattern. varPatName :: VarPat -> Name varPatName = Ident . varPatIdent @@ -340,11 +345,15 @@ instance Pretty VarPat where ------------------------------------------------------------------------------- -- @let@ Bindings -- ------------------------------------------------------------------------------- --- | A binding of a variable to an expression inside of a let clause +-- | A binding of a variable to an expression inside of a @let@-expression. data Bind = Bind { bindSrcSpan :: SrcSpan, bindVarPat :: VarPat, bindExpr :: Expr } deriving ( Eq, Show ) +-- | Instance to get the name of a @let@-binding.. +instance HasDeclIdent Bind where + declIdent = declIdent . bindVarPat + -- | Pretty instance for @let@ expression binds. instance Pretty Bind where pretty (Bind _ varPat expr) diff --git a/src/lib/FreeC/IR/Syntax/FuncDecl.hs b/src/lib/FreeC/IR/Syntax/FuncDecl.hs index 73fe692f..0f6eb93b 100644 --- a/src/lib/FreeC/IR/Syntax/FuncDecl.hs +++ b/src/lib/FreeC/IR/Syntax/FuncDecl.hs @@ -47,6 +47,10 @@ data FuncDecl = FuncDecl } deriving ( Eq, Show ) +-- | Instance to get the name of a function declaration. +instance HasDeclIdent FuncDecl where + declIdent = funcDeclIdent + -- | Gets the qualified name of the given function declaration. funcDeclQName :: FuncDecl -> QName funcDeclQName = declIdentName . funcDeclIdent @@ -74,7 +78,7 @@ funcDeclTypeScheme funcDecl = TypeScheme NoSrcSpan (funcDeclTypeArgs funcDecl) -- | Pretty instance for function declarations. instance Pretty FuncDecl where - pretty (FuncDecl _ declIdent typeArgs args maybeReturnType rhs) + pretty (FuncDecl _ declIdent' typeArgs args maybeReturnType rhs) = case maybeReturnType of Nothing -> prettyFuncHead <+> equals <+> pretty rhs Just returnType -> prettyFuncHead @@ -85,6 +89,6 @@ instance Pretty FuncDecl where where -- | The left-hand side of the function declaration. prettyFuncHead :: Doc - prettyFuncHead = pretty declIdent + prettyFuncHead = pretty declIdent' <+> hsep (map ((char '@' <>) . pretty) typeArgs) <+> hsep (map pretty args) diff --git a/src/lib/FreeC/IR/Syntax/Name.hs b/src/lib/FreeC/IR/Syntax/Name.hs index fc0bb793..30ea8a2e 100644 --- a/src/lib/FreeC/IR/Syntax/Name.hs +++ b/src/lib/FreeC/IR/Syntax/Name.hs @@ -119,6 +119,19 @@ instance Pretty DeclIdent where prettyList = prettySeparated (comma <> space) . map pretty +-- | Type class for AST nodes with a declaration identifier. +class HasDeclIdent node where + -- | Gets the name of the given AST node. + declIdent :: node -> DeclIdent + +-- | Gets the qualified name of the given AST node. +declQName :: HasDeclIdent node => node -> QName +declQName = declIdentName . declIdent + +-- | Gets the unqualified name of the given AST node. +declName :: HasDeclIdent node => node -> Name +declName = nameFromQName . declQName + ------------------------------------------------------------------------------- -- Internal Identifiers -- ------------------------------------------------------------------------------- diff --git a/src/lib/FreeC/IR/Syntax/TypeDecl.hs b/src/lib/FreeC/IR/Syntax/TypeDecl.hs index 2e2215de..b28bc1f0 100644 --- a/src/lib/FreeC/IR/Syntax/TypeDecl.hs +++ b/src/lib/FreeC/IR/Syntax/TypeDecl.hs @@ -25,6 +25,10 @@ data TypeDecl } deriving ( Eq, Show ) +-- | Instance to get the name of a type synonym or data type declaration. +instance HasDeclIdent TypeDecl where + declIdent = typeDeclIdent + -- | Gets the qualified name of the given type declaration. typeDeclQName :: TypeDecl -> QName typeDeclQName = declIdentName . typeDeclIdent @@ -35,16 +39,16 @@ typeDeclName = nameFromQName . typeDeclQName -- | Pretty instance for type declarations. instance Pretty TypeDecl where - pretty (DataDecl _ declIdent typeVarDecls conDecls) = prettyString "data" - <+> pretty declIdent + pretty (DataDecl _ declIdent' typeVarDecls conDecls) = prettyString "data" + <+> pretty declIdent' <+> hsep (map pretty typeVarDecls) <+> align (vcat (zipWith prettyConDecl [0 ..] conDecls)) where prettyConDecl :: Int -> ConDecl -> Doc prettyConDecl i conDecl | i == 0 = equals <+> pretty conDecl | otherwise = char '|' <+> pretty conDecl - pretty (TypeSynDecl _ declIdent typeVarDecls typeExpr) = prettyString "type" - <+> pretty declIdent + pretty (TypeSynDecl _ declIdent' typeVarDecls typeExpr) = prettyString "type" + <+> pretty declIdent' <+> hsep (map pretty typeVarDecls) <+> equals <+> pretty typeExpr @@ -59,6 +63,10 @@ data ConDecl = ConDecl { conDeclSrcSpan :: SrcSpan } deriving ( Eq, Show ) + -- | Instance to get the name of a constructor declaration. +instance HasDeclIdent ConDecl where + declIdent = conDeclIdent + -- | Gets the qualified name of the given constructor declaration. conDeclQName :: ConDecl -> QName conDeclQName = declIdentName . conDeclIdent @@ -69,5 +77,5 @@ conDeclName = nameFromQName . conDeclQName -- | Pretty instance for data constructor declarations. instance Pretty ConDecl where - pretty (ConDecl _ declIdent types) = pretty declIdent + pretty (ConDecl _ declIdent' types) = pretty declIdent' <+> hsep (map pretty types) From 29d623cebd31b7b96466d47efdf55cbd93e38437 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Fri, 11 Sep 2020 22:37:59 +0200 Subject: [PATCH 035/120] Generalize dependency graph creation #158 The dependency graph can now be created for all nodes that have a `HasRefs` and `HasDeclIdent` instance. This will allow us to sort bindings of `let`-expressions topologically. --- .../FreeC/Backend/Agda/Converter/Module.hs | 8 ++- .../Backend/Coq/Analysis/ConstantArguments.hs | 2 +- .../FreeC/Backend/Coq/Converter/FuncDecl.hs | 2 +- .../Backend/Coq/Converter/FuncDecl/NonRec.hs | 7 +-- src/lib/FreeC/Backend/Coq/Converter/Module.hs | 2 +- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 2 +- src/lib/FreeC/IR/DependencyGraph.hs | 61 ++++++++++--------- src/lib/FreeC/Pass/DependencyAnalysisPass.hs | 4 +- 8 files changed, 45 insertions(+), 43 deletions(-) diff --git a/src/lib/FreeC/Backend/Agda/Converter/Module.hs b/src/lib/FreeC/Backend/Agda/Converter/Module.hs index 8b8380cf..be8a09aa 100644 --- a/src/lib/FreeC/Backend/Agda/Converter/Module.hs +++ b/src/lib/FreeC/Backend/Agda/Converter/Module.hs @@ -12,7 +12,7 @@ import qualified FreeC.Backend.Agda.Syntax as Agda import FreeC.Environment ( lookupAvailableModule ) import FreeC.Environment.ModuleInterface ( interfaceAgdaLibName ) import FreeC.IR.DependencyGraph - ( groupFuncDecls, groupTypeDecls ) + ( typeDependencyComponents, valueDependencyComponents ) import FreeC.IR.Pragma import qualified FreeC.IR.Syntax as IR import FreeC.Monad.Converter @@ -27,9 +27,11 @@ convertModule (IR.Module _ name importDecls typeDecls _ modPragmas funcDecls) where importDecls' = Ap $ convertImportDecls importDecls - typeDecls' = Ap $ concatMapM convertTypeDecls $ groupTypeDecls typeDecls + typeDecls' + = Ap $ concatMapM convertTypeDecls $ typeDependencyComponents typeDecls - funcDecls' = Ap $ concatMapM convertFuncDecls $ groupFuncDecls funcDecls + funcDecls' + = Ap $ concatMapM convertFuncDecls $ valueDependencyComponents funcDecls -- | Converts an IR module name to an Agda module name. convertModName :: IR.ModName -> Agda.QName diff --git a/src/lib/FreeC/Backend/Coq/Analysis/ConstantArguments.hs b/src/lib/FreeC/Backend/Coq/Analysis/ConstantArguments.hs index 53578e5d..186963db 100644 --- a/src/lib/FreeC/Backend/Coq/Analysis/ConstantArguments.hs +++ b/src/lib/FreeC/Backend/Coq/Analysis/ConstantArguments.hs @@ -238,7 +238,7 @@ identifyConstArgs' decls = map Map.fromList -- | The dependency graph of the function declarations. callGraph :: DependencyGraph IR.FuncDecl - callGraph = funcDependencyGraph decls + callGraph = valueDependencyGraph decls -- | Tests whether the given strongly connected component describes a -- valid set of constant arguments. diff --git a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl.hs index 7e832dc9..f251ed2c 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl.hs @@ -15,7 +15,7 @@ import FreeC.Monad.Converter -- | Converts the given function declarations. convertFuncDecls :: [IR.FuncDecl] -> Converter [Coq.Sentence] convertFuncDecls funcDecls = do - let components = groupFuncDecls funcDecls + let components = valueDependencyComponents funcDecls concatMapM convertFuncComponent components -- | Converts a strongly connected component of the function dependency graph. diff --git a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/NonRec.hs b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/NonRec.hs index dbfb00ae..31ad8081 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/NonRec.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/NonRec.hs @@ -16,10 +16,9 @@ import FreeC.Monad.Converter -- into an ordered list of @Definition@ sentences such that each definition -- only depends on definitions at preceding list positions. convertNonRecFuncDecls :: [IR.FuncDecl] -> Converter [Coq.Sentence] -convertNonRecFuncDecls decls - = let orderedDecls = concatMap unwrapComponent - (dependencyComponents (funcDependencyGraph decls)) - in mapM convertNonRecFuncDecl orderedDecls +convertNonRecFuncDecls decls = do + let decls' = concatMap unwrapComponent (valueDependencyComponents decls) + mapM convertNonRecFuncDecl decls' -- | Converts a non-recursive Haskell function declaration to a Coq -- @Definition@ sentence. diff --git a/src/lib/FreeC/Backend/Coq/Converter/Module.hs b/src/lib/FreeC/Backend/Coq/Converter/Module.hs index 80b00368..db7f8864 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/Module.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/Module.hs @@ -41,7 +41,7 @@ convertDecls typeDecls funcDecls = do -- | Converts the given data type or type synonym declarations. convertTypeDecls :: [IR.TypeDecl] -> Converter [Coq.Sentence] convertTypeDecls typeDecls = do - let components = groupTypeDecls typeDecls + let components = typeDependencyComponents typeDecls concatMapM convertTypeComponent components ------------------------------------------------------------------------------- diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 9ab65290..6c125fc5 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -51,7 +51,7 @@ convertTypeComponent (Recursive decls) = do -- type synonyms from the same strongly connected component. Therefore we -- have to sort the declarations in reverse topological order. sortTypeSynDecls :: [IR.TypeDecl] -> Converter [IR.TypeDecl] -sortTypeSynDecls = mapM fromNonRecursive . groupTypeDecls +sortTypeSynDecls = mapM fromNonRecursive . typeDependencyComponents -- | Extracts the single type synonym declaration from a strongly connected -- component of the type dependency graph. diff --git a/src/lib/FreeC/IR/DependencyGraph.hs b/src/lib/FreeC/IR/DependencyGraph.hs index ebf70cbd..3843857c 100644 --- a/src/lib/FreeC/IR/DependencyGraph.hs +++ b/src/lib/FreeC/IR/DependencyGraph.hs @@ -14,12 +14,12 @@ -- keys for predefined functions (but not local variables) as well as the -- special functions @error@ and @undefined@ that are used in error terms. -- --- We distinguish between the type and function dependency graph. +-- We distinguish between the type and value dependency graph. -- This is because function declarations and type declarations -- live in separate scopes but we want to avoid name conflicts. -- Since we assume all type declarations to precede function declarations -- in the generated Coq code, this separation of the dependency graphs --- should not be a problem. For the same reason, the function dependency +-- should not be a problem. For the same reason, the value dependency -- graph does not include nodes for constructors (as always, the keys of -- used constructors are still present). -- @@ -45,15 +45,15 @@ module FreeC.IR.DependencyGraph , dependsDirectlyOn -- ** Constructors , typeDependencyGraph - , funcDependencyGraph + , valueDependencyGraph , moduleDependencyGraph -- * Strongly Connected Components , DependencyComponent(..) , unwrapComponent -- ** Constructors , dependencyComponents - , groupFuncDecls - , groupTypeDecls + , typeDependencyComponents + , valueDependencyComponents , groupModules -- ** Manipulating , mapComponent @@ -67,7 +67,7 @@ import Data.Graph import Data.Maybe ( mapMaybe ) import Data.Tuple.Extra -import FreeC.IR.Reference ( typeRefs, valueRefs ) +import FreeC.IR.Reference ( HasRefs, typeRefs, valueRefs ) import qualified FreeC.IR.Syntax as IR import FreeC.Pretty @@ -140,29 +140,28 @@ dependsDirectlyOn graph k1 k2 = containsEdge == Just True ------------------------------------------------------------------------------- -- Type Dependencies -- ------------------------------------------------------------------------------- --- | Creates the dependency graph for a list of data type or type synonym --- declarations. -typeDependencyGraph :: [IR.TypeDecl] -> DependencyGraph IR.TypeDecl +-- | Creates the type dependency graph for a list of nodes. typeDependencyGraph - = uncurry3 DependencyGraph . graphFromEdges . map typeDeclEntry + :: (HasRefs node, IR.HasDeclIdent node) => [node] -> DependencyGraph node +typeDependencyGraph = uncurry3 DependencyGraph . graphFromEdges . map typeEntry --- | Creates an entry of the dependency graph for the given data type or type --- synonym declaration. -typeDeclEntry :: IR.TypeDecl -> DGEntry IR.TypeDecl -typeDeclEntry decl = (decl, IR.typeDeclQName decl, typeRefs decl) +-- | Creates an entry of the type dependency graph. +typeEntry :: (HasRefs node, IR.HasDeclIdent node) => node -> DGEntry node +typeEntry node = (node, IR.declQName node, typeRefs node) ------------------------------------------------------------------------------- -- Function Dependencies -- ------------------------------------------------------------------------------- -- | Creates the dependency graph for a list of function declarations. -funcDependencyGraph :: [IR.FuncDecl] -> DependencyGraph IR.FuncDecl -funcDependencyGraph - = uncurry3 DependencyGraph . graphFromEdges . map funcDeclEntry +valueDependencyGraph + :: (HasRefs node, IR.HasDeclIdent node) => [node] -> DependencyGraph node +valueDependencyGraph + = uncurry3 DependencyGraph . graphFromEdges . map valueEntry -- | Creates an entry of the dependency graph for the given function -- declaration or pattern binding. -funcDeclEntry :: IR.FuncDecl -> DGEntry IR.FuncDecl -funcDeclEntry decl = (decl, IR.funcDeclQName decl, valueRefs decl) +valueEntry :: (HasRefs node, IR.HasDeclIdent node) => node -> DGEntry node +valueEntry node = (node, IR.declQName node, valueRefs node) ------------------------------------------------------------------------------- -- Module Dependencies -- @@ -273,17 +272,19 @@ dependencyComponents = map convertSCC . stronglyConnComp . dgEntries convertSCC (AcyclicSCC decl) = NonRecursive decl convertSCC (CyclicSCC decls) = Recursive decls --- | Combines the construction of the dependency graphs for the given --- type declarations (See 'typeDependencyGraph') with the computation of --- strongly connected components. -groupTypeDecls :: [IR.TypeDecl] -> [DependencyComponent IR.TypeDecl] -groupTypeDecls = dependencyComponents . typeDependencyGraph - --- | Combines the construction of the dependency graphs for the given --- function declarations (See 'funcDependencyGraph') with the computation --- of strongly connected components. -groupFuncDecls :: [IR.FuncDecl] -> [DependencyComponent IR.FuncDecl] -groupFuncDecls = dependencyComponents . funcDependencyGraph +-- | Combines the construction of the type dependency graph with the +-- computation of strongly connected components. +typeDependencyComponents :: (HasRefs node, IR.HasDeclIdent node) + => [node] + -> [DependencyComponent node] +typeDependencyComponents = dependencyComponents . typeDependencyGraph + +-- | Combines the construction of the value dependency graph with the +-- computation of strongly connected components. +valueDependencyComponents :: (HasRefs node, IR.HasDeclIdent node) + => [node] + -> [DependencyComponent node] +valueDependencyComponents = dependencyComponents . valueDependencyGraph -- | Combines the construction of the dependency graph for the given -- modules (See 'moduleDependencyGraph') with the computation of strongly diff --git a/src/lib/FreeC/Pass/DependencyAnalysisPass.hs b/src/lib/FreeC/Pass/DependencyAnalysisPass.hs index 74eee74e..73f68fae 100644 --- a/src/lib/FreeC/Pass/DependencyAnalysisPass.hs +++ b/src/lib/FreeC/Pass/DependencyAnalysisPass.hs @@ -64,7 +64,7 @@ class DependencyAnalysisPass decl where -- | The dependencies of type declarations can be analyzed. instance DependencyAnalysisPass IR.TypeDecl where - groupDecls = groupTypeDecls + groupDecls = typeDependencyComponents getDecls = IR.modTypeDecls @@ -72,7 +72,7 @@ instance DependencyAnalysisPass IR.TypeDecl where -- | The dependencies of function declarations can be analyzed. instance DependencyAnalysisPass IR.FuncDecl where - groupDecls = groupFuncDecls + groupDecls = valueDependencyComponents getDecls = IR.modFuncDecls From 42268b11463f110be2e4a7b6f0fa0500a1ba5fb6 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Fri, 11 Sep 2020 22:40:03 +0200 Subject: [PATCH 036/120] Add utility function to map subterms #158 We often have to traverse the AST to apply a function on some nodes but want to leave all other nodes unmodified. The existing subterm functions can be used to traverse the AST without having to handle every constructor explicitly. The new helper function provides a convenient interface for applying a function on a node and all of its subterms. --- src/lib/FreeC/IR/Subterm.hs | 54 ++++++++++++++++++++++++++++++------- 1 file changed, 44 insertions(+), 10 deletions(-) diff --git a/src/lib/FreeC/IR/Subterm.hs b/src/lib/FreeC/IR/Subterm.hs index 851b57b0..3ced812c 100644 --- a/src/lib/FreeC/IR/Subterm.hs +++ b/src/lib/FreeC/IR/Subterm.hs @@ -28,21 +28,25 @@ module FreeC.IR.Subterm , findSubtermPos , findSubterms , findFirstSubterm + -- * Replacing Subterms + , mapSubterms + , mapSubtermsM -- * Bound Variables , boundVarsAt , boundVarsWithTypeAt ) where -import Control.Monad ( foldM ) -import Data.Composition ( (.:) ) -import Data.List ( intersperse, isPrefixOf ) -import Data.Map.Strict ( Map ) -import qualified Data.Map.Strict as Map -import Data.Maybe ( fromMaybe, listToMaybe ) -import Data.Set ( Set ) -import Data.Tuple.Extra ( (&&&) ) - -import qualified FreeC.IR.Syntax as IR +import Control.Monad ( foldM ) +import Data.Composition ( (.:) ) +import Data.Functor.Identity ( runIdentity ) +import Data.List ( intersperse, isPrefixOf ) +import Data.Map.Strict ( Map ) +import qualified Data.Map.Strict as Map +import Data.Maybe ( fromMaybe, listToMaybe ) +import Data.Set ( Set ) +import Data.Tuple.Extra ( (&&&) ) + +import qualified FreeC.IR.Syntax as IR import FreeC.Pretty ------------------------------------------------------------------------------- @@ -89,6 +93,20 @@ class Pretty a => Subterm a where -- | Replaces the child nodes of the given AST node. replaceChildTerms :: a -> [a] -> Maybe a +-- | Like 'replaceChildTerms' but throws an error if the wrong number of child +-- terms is provided. +replaceChildTerms' :: Subterm a => a -> [a] -> a +replaceChildTerms' term children' = fromMaybe argCountError + (replaceChildTerms term children') + where + -- | The error to throw when the wrong number of new child terms is provided. + argCountError = error + $ "replaceChildTerms: Wrong number of child terms. Got " + ++ show (length children') + ++ " but expected " + ++ show (length (childTerms term)) + ++ "!" + -- | Expressions have subterms. instance Subterm IR.Expr where -- | Gets the direct child expression nodes of the given expression. @@ -292,6 +310,22 @@ findSubterms predicate term = filter predicate findFirstSubterm :: Subterm a => (a -> Bool) -> a -> Maybe a findFirstSubterm = listToMaybe .: findSubterms +------------------------------------------------------------------------------- +-- Replacing for Subterms -- +------------------------------------------------------------------------------- +-- | Applies the given function to all subterms of the given node. +-- +-- The subterms of the returned expression are replaced recursively. +mapSubterms :: Subterm a => (a -> a) -> a -> a +mapSubterms f = runIdentity . mapSubtermsM (return . f) + +-- Monadic version of 'mapSubterms'. +mapSubtermsM :: (Subterm a, Monad m) => (a -> m a) -> a -> m a +mapSubtermsM f term = do + term' <- f term + children' <- mapM (mapSubtermsM f) (childTerms term') + return (replaceChildTerms' term' children') + ------------------------------------------------------------------------------- -- Bound Variables -- ------------------------------------------------------------------------------- From 8593eaba1b6ddc5a1b4703283200f351c6f93016 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Fri, 11 Sep 2020 22:43:57 +0200 Subject: [PATCH 037/120] Add pass to sort `let`-bindings #158 --- free-compiler.cabal | 1 + src/lib/FreeC/Pass/LetSortPass.hs | 100 ++++++++++++++++++++++++++++++ src/lib/FreeC/Pipeline.hs | 2 + 3 files changed, 103 insertions(+) create mode 100644 src/lib/FreeC/Pass/LetSortPass.hs diff --git a/free-compiler.cabal b/free-compiler.cabal index 4c6dc913..922dd63a 100644 --- a/free-compiler.cabal +++ b/free-compiler.cabal @@ -177,6 +177,7 @@ library freec-internal , FreeC.Pass.ImplicitPreludePass , FreeC.Pass.ImportPass , FreeC.Pass.KindCheckPass + , FreeC.Pass.LetSortPass , FreeC.Pass.PartialityAnalysisPass , FreeC.Pass.TypeInferencePass , FreeC.Pass.TypeSignaturePass diff --git a/src/lib/FreeC/Pass/LetSortPass.hs b/src/lib/FreeC/Pass/LetSortPass.hs new file mode 100644 index 00000000..47f214d1 --- /dev/null +++ b/src/lib/FreeC/Pass/LetSortPass.hs @@ -0,0 +1,100 @@ +-- | This module contains a compiler pass that brings the bindings of all +-- @let@-expressions in a module into reverse topological order. +-- +-- = Examples +-- +-- == Example 1 +-- +-- The bindings of the following @let@-expression are not topologically +-- sorted because the right-hand side of @x@ depends on @y@ but @y@ is +-- defined after @x@. +-- +-- > let { x = y; y = 42 } in x +-- +-- This pass transforms the @let@-expression above into the following form. +-- +-- > let { y = 42; x = y } in x +-- +-- == Example 2 +-- +-- If a @let@-expression contains (mutually) recursive bindings, a fatal +-- error is reported. +-- +-- > let { x = y; y = x } in x +-- +-- It is not clear at the moment how mutually recursive local variables +-- can be represented when the sharing effect is used. +-- +-- = Specification +-- +-- == Preconditions +-- +-- There are no special requirements. +-- +-- == Translations +-- +-- Every @let@-expression +-- +-- > let { x₁ = e₁; …; xₙ = eₙ } in e +-- +-- is transformed into a @let@-expression +-- +-- > let { y₁ = f₁; …; yₙ = fₙ } in e +-- +-- where @y₁ = f₁, …, yₙ = fₙ@ is a permutation of @x₁ = e₁, …, xₙ = eₙ@ +-- such that for every @1 ≤ i ≤ n@ the expression @fᵢ@ contains no free +-- variables @xⱼ@ with @j ≥ i@, i.e., all variables bound by the new +-- @let@-expression are not used before they are declared. If there is no +-- such permutation a fatal error is reported. +-- +-- == Postcondition +-- +-- The bindings of all @let@-expressions are in reverse topological order and +-- there are no recursive or mutually recursive bindings. +module FreeC.Pass.LetSortPass ( letSortPass ) where + +import FreeC.IR.DependencyGraph +import FreeC.IR.SrcSpan +import FreeC.IR.Subterm +import qualified FreeC.IR.Syntax as IR +import FreeC.Monad.Reporter +import FreeC.Pass +import FreeC.Pretty + +-- | A pass that sorts the bindings of @let@-expressions topologically. +letSortPass :: Pass IR.Module IR.Module +letSortPass ast = do + funcDecls' <- mapM sortFuncDecl (IR.modFuncDecls ast) + return ast { IR.modFuncDecls = funcDecls' } + +-- | Sorts all @let@-expressions on the right-hand side of the given function +-- declaration topologically. +sortFuncDecl :: MonadReporter r => IR.FuncDecl -> r IR.FuncDecl +sortFuncDecl funcDecl = do + rhs' <- sortExpr (IR.funcDeclRhs funcDecl) + return funcDecl { IR.funcDeclRhs = rhs' } + +-- | Sorts all @let@-expressions in the given expression topologically. +sortExpr :: MonadReporter r => IR.Expr -> r IR.Expr +sortExpr = mapSubtermsM sortLet + where + sortLet :: MonadReporter r => IR.Expr -> r IR.Expr + sortLet (IR.Let srcSpan binds expr exprType) = do + let components = valueDependencyComponents binds + binds' <- mapM (fromNonRecursive srcSpan) components + return (IR.Let srcSpan binds' expr exprType) + sortLet expr = return expr + + -- | Extracts the single non-recursive @let@-binding from the given strongly + -- connected component of the dependency graph. + -- + -- Reports a fatal error with the given source span if the bindings in the + -- component are recursive. + fromNonRecursive + :: MonadReporter r => SrcSpan -> DependencyComponent IR.Bind -> r IR.Bind + fromNonRecursive _ (NonRecursive bind) = return bind + fromNonRecursive srcSpan (Recursive binds) = reportFatal + $ Message srcSpan Error + $ "Recursive `let`-bindings are not supported but the bindings for " + ++ showPretty (map IR.declName binds) + ++ " form a cycle." diff --git a/src/lib/FreeC/Pipeline.hs b/src/lib/FreeC/Pipeline.hs index f3d7ebf1..8a0d216d 100644 --- a/src/lib/FreeC/Pipeline.hs +++ b/src/lib/FreeC/Pipeline.hs @@ -19,6 +19,7 @@ import FreeC.Pass.ExportPass import FreeC.Pass.ImplicitPreludePass import FreeC.Pass.ImportPass import FreeC.Pass.KindCheckPass +import FreeC.Pass.LetSortPass import FreeC.Pass.PartialityAnalysisPass import FreeC.Pass.QualifierPass import FreeC.Pass.ResolverPass @@ -33,6 +34,7 @@ pipeline = implicitPreludePass >=> importPass >=> dependencyAnalysisPass defineTypeDeclsPass >=> kindCheckPass + >=> letSortPass >=> typeSignaturePass >=> dependencyAnalysisPass (typeInferencePass >=> defineFuncDeclsPass >=> partialityAnalysisPass) From dae7d6c2677ae886b3ea6e937f195e81bd020ee6 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Fri, 11 Sep 2020 22:57:06 +0200 Subject: [PATCH 038/120] Add tests for sorting of `let`-bindings #158 --- free-compiler.cabal | 1 + src/lib/FreeC/Pass/LetSortPass.hs | 12 +++++--- src/test/FreeC/Pass/KindCheckPassTests.hs | 4 +-- src/test/FreeC/Pass/LetSortPassTests.hs | 34 +++++++++++++++++++++++ src/test/FreeC/PipelineTests.hs | 2 ++ 5 files changed, 47 insertions(+), 6 deletions(-) create mode 100644 src/test/FreeC/Pass/LetSortPassTests.hs diff --git a/free-compiler.cabal b/free-compiler.cabal index 922dd63a..4b8afa6b 100644 --- a/free-compiler.cabal +++ b/free-compiler.cabal @@ -256,6 +256,7 @@ test-suite freec-unit-tests , FreeC.Pass.EtaConversionPassTests , FreeC.Pass.ExportPassTests , FreeC.Pass.KindCheckPassTests + , FreeC.Pass.LetSortPassTests , FreeC.Pass.PartialityAnalysisPassTests , FreeC.Pass.ResolverPassTests , FreeC.Pass.TypeInferencePassTests diff --git a/src/lib/FreeC/Pass/LetSortPass.hs b/src/lib/FreeC/Pass/LetSortPass.hs index 47f214d1..d78de463 100644 --- a/src/lib/FreeC/Pass/LetSortPass.hs +++ b/src/lib/FreeC/Pass/LetSortPass.hs @@ -51,7 +51,11 @@ -- -- The bindings of all @let@-expressions are in reverse topological order and -- there are no recursive or mutually recursive bindings. -module FreeC.Pass.LetSortPass ( letSortPass ) where +module FreeC.Pass.LetSortPass + ( letSortPass + -- * Testing Interface + , sortLetExprs + ) where import FreeC.IR.DependencyGraph import FreeC.IR.SrcSpan @@ -71,12 +75,12 @@ letSortPass ast = do -- declaration topologically. sortFuncDecl :: MonadReporter r => IR.FuncDecl -> r IR.FuncDecl sortFuncDecl funcDecl = do - rhs' <- sortExpr (IR.funcDeclRhs funcDecl) + rhs' <- sortLetExprs (IR.funcDeclRhs funcDecl) return funcDecl { IR.funcDeclRhs = rhs' } -- | Sorts all @let@-expressions in the given expression topologically. -sortExpr :: MonadReporter r => IR.Expr -> r IR.Expr -sortExpr = mapSubtermsM sortLet +sortLetExprs :: MonadReporter r => IR.Expr -> r IR.Expr +sortLetExprs = mapSubtermsM sortLet where sortLet :: MonadReporter r => IR.Expr -> r IR.Expr sortLet (IR.Let srcSpan binds expr exprType) = do diff --git a/src/test/FreeC/Pass/KindCheckPassTests.hs b/src/test/FreeC/Pass/KindCheckPassTests.hs index cec98332..cf19e88e 100644 --- a/src/test/FreeC/Pass/KindCheckPassTests.hs +++ b/src/test/FreeC/Pass/KindCheckPassTests.hs @@ -1,5 +1,5 @@ -- | This module contains tests for "FreeC.Pass.KindCheckPass". -module FreeC.Pass.KindCheckPassTests where +module FreeC.Pass.KindCheckPassTests ( testKindCheckPass ) where import Test.Hspec @@ -10,7 +10,7 @@ import FreeC.Test.Parser -- | Test group for 'kindCheckPass' tests. testKindCheckPass :: Spec -testKindCheckPass = describe "FreeC.Pass.KindCheckPassTests" $ do +testKindCheckPass = describe "FreeC.Pass.KindCheckPass" $ do testValidTypes testNotValidTypes diff --git a/src/test/FreeC/Pass/LetSortPassTests.hs b/src/test/FreeC/Pass/LetSortPassTests.hs new file mode 100644 index 00000000..f15477d6 --- /dev/null +++ b/src/test/FreeC/Pass/LetSortPassTests.hs @@ -0,0 +1,34 @@ +-- | This module contains tests for "FreeC.Pass.LetSortPass". +module FreeC.Pass.LetSortPassTests ( testLetSortPass ) where + +import Test.Hspec + +import qualified FreeC.IR.Syntax as IR +import FreeC.Monad.Class.Testable +import FreeC.Monad.Reporter +import FreeC.Pass.LetSortPass +import FreeC.Test.Expectations +import FreeC.Test.Parser + +-- | Test group for 'letSortPass' tests. +testLetSortPass :: Spec +testLetSortPass = describe "FreeC.Pass.LetSortPass" $ do + it "sorts `let`-bindings topologically" $ shouldSucceedWith $ do + input <- parseTestExpr "let { x = y; y = 42 } in x" + expectedOutput <- parseTestExpr "let { y = 42; x = y } in x" + output <- sortLetExprs input :: Reporter IR.Expr + return (output `shouldBeSimilarTo` expectedOutput) + it "leaves topologically sorted `let`-bindings unchanged" + $ shouldSucceedWith + $ do + input <- parseTestExpr "let { x = 42; y = x } in y" + output <- sortLetExprs input :: Reporter IR.Expr + return (output `shouldBeSimilarTo` input) + it "rejects recursive `let`-bindings" $ do + input <- expectParseTestExpr "let { x = x } in x" + shouldFailPretty $ do + sortLetExprs input :: Reporter IR.Expr + it "rejects mutually recursive `let`-bindings" $ do + input <- expectParseTestExpr "let { x = y; y = x } in y" + shouldFailPretty $ do + sortLetExprs input :: Reporter IR.Expr diff --git a/src/test/FreeC/PipelineTests.hs b/src/test/FreeC/PipelineTests.hs index 13e0be27..59043171 100644 --- a/src/test/FreeC/PipelineTests.hs +++ b/src/test/FreeC/PipelineTests.hs @@ -8,6 +8,7 @@ import FreeC.Pass.CompletePatternPassTests import FreeC.Pass.EtaConversionPassTests import FreeC.Pass.ExportPassTests import FreeC.Pass.KindCheckPassTests +import FreeC.Pass.LetSortPassTests import FreeC.Pass.PartialityAnalysisPassTests import FreeC.Pass.ResolverPassTests import FreeC.Pass.TypeInferencePassTests @@ -19,6 +20,7 @@ testPipeline = do testEtaConversionPass testExportPass testKindCheckPass + testLetSortPass testPartialityAnalysisPass testResolverPass testTypeInferencePass From a2568a3f010800ee04df3d246bb9c7ec15b114aa Mon Sep 17 00:00:00 2001 From: Daniel Teut Date: Mon, 14 Sep 2020 02:07:36 +0200 Subject: [PATCH 039/120] Add `Call` to LIR #196 --- src/lib/FreeC/Backend/Agda/Converter/Expr.hs | 2 ++ src/lib/FreeC/Backend/Coq/Base.hs | 8 +++++++- src/lib/FreeC/Backend/Coq/Converter/Expr.hs | 6 ++++++ src/lib/FreeC/LiftedIR/Syntax/Expr.hs | 5 +++++ 4 files changed, 20 insertions(+), 1 deletion(-) diff --git a/src/lib/FreeC/Backend/Agda/Converter/Expr.hs b/src/lib/FreeC/Backend/Agda/Converter/Expr.hs index 81e9d023..00cf9da9 100644 --- a/src/lib/FreeC/Backend/Agda/Converter/Expr.hs +++ b/src/lib/FreeC/Backend/Agda/Converter/Expr.hs @@ -37,6 +37,8 @@ convertLiftedExpr (LIR.Undefined _) = return undefinedExpr convertLiftedExpr (LIR.ErrorExpr _) = return errorExpr convertLiftedExpr (LIR.Share _ expr _) = generatePure <$> convertLiftedExpr expr +convertLiftedExpr (LIR.Call _ expr _) + = generatePure <$> convertLiftedExpr expr -- | Converts a single pattern from a LIR case expression to an Agda -- expression. diff --git a/src/lib/FreeC/Backend/Coq/Base.hs b/src/lib/FreeC/Backend/Coq/Base.hs index ac3b4843..42e09ca5 100644 --- a/src/lib/FreeC/Backend/Coq/Base.hs +++ b/src/lib/FreeC/Backend/Coq/Base.hs @@ -27,6 +27,7 @@ module FreeC.Backend.Coq.Base , shareableArgsBinder , implicitArg , share + , call -- * Effect Selection , selectExplicitArgs , selectImplicitArgs @@ -174,10 +175,14 @@ shareableArgsBinder typeArg = Coq.Generalized Coq.Implicit implicitArg :: Coq.Term implicitArg = Coq.Underscore --- | The Coq Identifier for the @share@ operator. +-- | The Coq identifier for the @share@ operator. share :: Coq.Qualid share = Coq.bare "share" +-- | The Coq identifier for the @call@ operator. +call :: Coq.Qualid +call = Coq.bare "call" + ------------------------------------------------------------------------------- -- Effect selection -- ------------------------------------------------------------------------------- @@ -242,5 +247,6 @@ reservedIdents , strategyArg , shareableArgs , share + , call ] ++ map fst freeArgs diff --git a/src/lib/FreeC/Backend/Coq/Converter/Expr.hs b/src/lib/FreeC/Backend/Coq/Converter/Expr.hs index 8266532d..882904cb 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/Expr.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/Expr.hs @@ -77,6 +77,12 @@ convertLiftedExpr (LIR.Share _ arg argType) = do $ genericApply' (Coq.Qualid Coq.Base.share) [Coq.Qualid Coq.Base.strategyArg] [] (maybeToList argType') [Coq.Base.implicitArg] [arg'] +convertLiftedExpr (LIR.Call _ arg argType) = do + arg' <- convertLiftedExpr arg + argType' <- mapM convertLiftedType argType + return + $ genericApply' (Coq.Qualid Coq.Base.call) + [Coq.Qualid Coq.Base.strategyArg] [] (maybeToList argType') [] [arg'] -- | Converts a Haskell expression to Coq. convertExpr :: IR.Expr -> Converter Coq.Term diff --git a/src/lib/FreeC/LiftedIR/Syntax/Expr.hs b/src/lib/FreeC/LiftedIR/Syntax/Expr.hs index e643d843..f6740be3 100644 --- a/src/lib/FreeC/LiftedIR/Syntax/Expr.hs +++ b/src/lib/FreeC/LiftedIR/Syntax/Expr.hs @@ -69,6 +69,11 @@ data Expr , exprShareArg :: Expr , exprShareType :: Maybe Type } + -- | The @call@ operator. + | Call { exprSrcSpan :: SrcSpan + , exprCallArg :: Expr + , exprCallType :: Maybe Type + } deriving ( Eq, Show ) ------------------------------------------------------------------------------- From 6d0da01a566ee3b8def30d2684ae7da2029904bd Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 14 Sep 2020 13:18:56 +0200 Subject: [PATCH 040/120] Use Coq.Base functions added to the main branch #150 --- src/lib/FreeC/Backend/Coq/Base.hs | 14 +++------ .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 29 ++++++++++--------- 2 files changed, 19 insertions(+), 24 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Base.hs b/src/lib/FreeC/Backend/Coq/Base.hs index 21964ad4..46d42fd2 100644 --- a/src/lib/FreeC/Backend/Coq/Base.hs +++ b/src/lib/FreeC/Backend/Coq/Base.hs @@ -11,8 +11,10 @@ module FreeC.Backend.Coq.Base , freeImpureCon , freeBind , freeArgs - , shapeAndPos - , idShapeAndPos + , shape + , shapeIdent + , pos + , posIdent -- * Partiality , partial , partialArg @@ -103,14 +105,6 @@ freeArgs = [ (shape, Coq.Sort Coq.Type) , (pos, Coq.Arrow (Coq.Qualid shape) (Coq.Sort Coq.Type)) ] --- | The names of the parameters that mus be passed to the @Free@ monad. -shapeAndPos :: [Coq.Qualid] -shapeAndPos = map fst freeArgs - --- | The shape and position function representing the Identity monad. -idShapeAndPos :: [Coq.Qualid] -idShapeAndPos - = [Coq.qualified "Identity" "Shape", Coq.qualified "Identity" "Pos"] ------------------------------------------------------------------------------- -- Partiality -- diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index bb04b2bb..69befd90 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -582,9 +582,9 @@ nfBindersAndReturnType t varName = do let constraints = map (buildConstraint normalformClassName) (zipWith (\v1 v2 -> [v1, v2]) sourceVars targetVars) let varBinders - = [typeBinder (sourceVars ++ targetVars) | not (null sourceVars)] + = [typeVarBinder (sourceVars ++ targetVars) | not (null sourceVars)] let binders = varBinders ++ constraints - let topLevelVarBinder = Coq.typedBinder' Coq.Explicit varName sourceType + let topLevelVarBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit varName sourceType let instanceRetType = Coq.app (Coq.Qualid (Coq.bare normalformClassName)) (shapeAndPos ++ [sourceType, targetType]) let funcRetType = applyFree targetType @@ -642,7 +642,7 @@ buildNormalformValue nameMap consName = buildNormalformValue' [] ------------------------------------------------------------------------------- -- Helper functions -- ------------------------------------------------------------------------------- --- Like showPretty, but uses the Coq identifiers of the type and its components. +-- Like @showPretty@, but uses the Coq identifiers of the type and its components. showPrettyType :: IR.Type -> Converter String -- For a type variable, show its name. @@ -683,9 +683,15 @@ freeArgsBinders :: [Coq.Binder] freeArgsBinders = genericArgDecls Coq.Implicit -- Shortcut for the construction of an implicit binder for type variables. --- typeBinder [a1, ..., an] = {a1 ... an : Type} -typeBinder :: [Coq.Qualid] -> Coq.Binder -typeBinder typeVars = Coq.typedBinder Coq.Implicit typeVars Coq.sortType +-- typeVarBinder [a1, ..., an] = {a1 ... an : Type} +typeVarBinder :: [Coq.Qualid] -> Coq.Binder +typeVarBinder typeVars = Coq.typedBinder Coq.Ungeneralizable Coq.Implicit typeVars Coq.sortType + +-- | Constructs a type class constraint. +-- > buildConstraint name [a1 ... an] = `{name Shape Pos a1 ... an}. +buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder +buildConstraint className args = Coq.Generalized Coq.Implicit + (Coq.app (Coq.Qualid (Coq.bare className)) (shapeAndPos ++ map Coq.Qualid args)) -- Shortcut for the application of >>=. applyBind :: Coq.Term -> Coq.Term -> Coq.Term @@ -697,18 +703,13 @@ applyFree a = Coq.app (Coq.Qualid Coq.Base.free) (shapeAndPos ++ [a]) -- | Shape and Pos arguments as Coq terms. shapeAndPos :: [Coq.Term] -shapeAndPos = map Coq.Qualid Coq.Base.shapeAndPos +shapeAndPos = [Coq.Qualid Coq.Base.shape, Coq.Qualid Coq.Base.pos] -- | The shape and position function arguments for the Identity monad -- as a Coq term. idShapeAndPos :: [Coq.Term] -idShapeAndPos = map Coq.Qualid Coq.Base.idShapeAndPos - --- | Constructs a type class constraint. --- > buildConstraint name [a1 ... an] = `{name Shape Pos a1 ... an}. -buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder -buildConstraint ident args = Coq.Generalized Coq.Implicit - (Coq.app (Coq.Qualid (Coq.bare ident)) (shapeAndPos ++ map Coq.Qualid args)) +idShapeAndPos = map Coq.Qualid [Coq.Qualified (Coq.ident "Identity") Coq.Base.shapeIdent + , Coq.Qualified (Coq.ident "Identity") Coq.Base.posIdent] -- | Converts a type into a Coq type (a term) with the specified -- additional arguments (for example Shape and Pos) and new variables for all From d56b21d91c699cc430486aa670277d7ee075812d Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 14 Sep 2020 14:08:39 +0200 Subject: [PATCH 041/120] Make helper functions local #150 --- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 363 +++++++++--------- 1 file changed, 182 insertions(+), 181 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 69befd90..e91dcb64 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -421,7 +421,8 @@ generateTypeclassInstances dataDecls = do (Coq.InstanceDefinition instanceName (freeArgsBinders ++ binders) retType [instanceBody] Nothing) - -- | Generates the implementation of a class function for the given type. + -- | Generates the implementation of the body of a class function for the + -- given type. makeFixBody :: -- A mapping from (indirectly or directly) recursive types to the name @@ -502,9 +503,91 @@ generateTypeclassInstances dataDecls = do rhs <- buildValue m conIdent (zip modArgTypes conArgIdents) return $ Coq.equation lhs rhs - ----------------------------------------------------------------------------- - -- Type Analysis -- - ----------------------------------------------------------------------------- + ------------------------------------------------------------------------------- + -- Typeclass-specific Functions -- + ------------------------------------------------------------------------------- + ------------------------------------------------------------------------------- + -- Functions to produce Normalform instances -- + ------------------------------------------------------------------------------- + normalformClassName :: String + normalformClassName = "Normalform" + + normalformFuncName :: String + normalformFuncName = "nf'" + + nfBindersAndReturnType + :: IR.Type + -> Coq.Qualid + -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) + nfBindersAndReturnType t varName = do + (sourceType, sourceVars) <- toCoqType "a" shapeAndPos t + (targetType, targetVars) <- toCoqType "b" idShapeAndPos t + let constraints = map (buildConstraint normalformClassName) + (zipWith (\v1 v2 -> [v1, v2]) sourceVars targetVars) + let varBinders + = [typeVarBinder (sourceVars ++ targetVars) | not (null sourceVars)] + let binders = varBinders ++ constraints + let topLevelVarBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit varName sourceType + let instanceRetType = Coq.app (Coq.Qualid (Coq.bare normalformClassName)) + (shapeAndPos ++ [sourceType, targetType]) + let funcRetType = applyFree targetType + return (binders, topLevelVarBinder, funcRetType, instanceRetType) + + -- | Builds a normalized @Free@ value for the given constructor + -- and constructor parameters. + buildNormalformValue + -- A map to associate types with the appropriate functions to call. + :: TypeMap + -- The name of the constructor used to build the value. + -> Coq.Qualid + -- The types and names of the constructor's parameters. + -> [(IR.Type, Coq.Qualid)] + -> Converter Coq.Term + buildNormalformValue nameMap consName = buildNormalformValue' [] + where + -- | Like 'buildNormalformValue', but with an additional parameter to accumulate + -- bound variables. + buildNormalformValue' + :: [Coq.Qualid] -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term + + -- If all components have been normalized, apply the constructor to + -- the normalized components. + buildNormalformValue' boundVars [] = do + args <- mapM (generatePure . Coq.Qualid) (reverse boundVars) + generatePure (Coq.app (Coq.Qualid consName) args) + -- For each component, apply the appropriate function, bind the + -- result and do the remaining computation. + buildNormalformValue' boundVars ((t, varName) : consVars) + = case Map.lookup t nameMap of + -- For recursive or indirectly recursive calls, the type map + -- returns the name of the appropriate function to call. + Just funcName -> do + -- Because the functions work on bare values, the component + -- must be bound (to a fresh variable). + x <- Coq.bare <$> freshCoqIdent freshArgPrefix + -- The result of the normalization will also be bound to a fresh variable. + nx <- Coq.bare <$> freshCoqIdent ("n" ++ freshArgPrefix) + -- Do the rest of the computation with the added bound result. + rhs <- buildNormalformValue' (nx : boundVars) consVars + -- Construct the actual bindings and return the result. + let c = Coq.fun [nx] [Nothing] rhs + let c' = applyBind (Coq.app (Coq.Qualid funcName) [Coq.Qualid x]) c + return $ applyBind (Coq.Qualid varName) (Coq.fun [x] [Nothing] c') + -- If there is no entry in the type map, we can assume that an instance + -- already exists. Therefore, we apply @nf@ to the component to receive + -- a normalized value. + Nothing -> do + nx <- Coq.bare <$> freshCoqIdent ("n" ++ freshArgPrefix) + rhs <- buildNormalformValue' (nx : boundVars) consVars + let c = Coq.fun [nx] [Nothing] rhs + return + $ applyBind (Coq.app (Coq.Qualid (Coq.bare "nf")) + [Coq.Qualid varName]) c + + ------------------------------------------------------------------------------- + -- Helper functions -- + ------------------------------------------------------------------------------- + -- | Creates an entry with a unique name for each of the given types and -- inserts them into the given map. nameFunctionsAndInsert :: String -> TypeMap -> [IR.Type] -> Converter TypeMap @@ -560,180 +643,98 @@ generateTypeclassInstances dataDecls = do -- Type variables and function types are not relevant and are replaced by "_". stripType' _ _ = IR.TypeVar NoSrcSpan "_" -------------------------------------------------------------------------------- --- Typeclass-specific Functions -- -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- --- Functions to produce Normalform instances -- -------------------------------------------------------------------------------- -normalformClassName :: String -normalformClassName = "Normalform" - -normalformFuncName :: String -normalformFuncName = "nf'" - -nfBindersAndReturnType - :: IR.Type - -> Coq.Qualid - -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) -nfBindersAndReturnType t varName = do - (sourceType, sourceVars) <- toCoqType "a" shapeAndPos t - (targetType, targetVars) <- toCoqType "b" idShapeAndPos t - let constraints = map (buildConstraint normalformClassName) - (zipWith (\v1 v2 -> [v1, v2]) sourceVars targetVars) - let varBinders - = [typeVarBinder (sourceVars ++ targetVars) | not (null sourceVars)] - let binders = varBinders ++ constraints - let topLevelVarBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit varName sourceType - let instanceRetType = Coq.app (Coq.Qualid (Coq.bare normalformClassName)) - (shapeAndPos ++ [sourceType, targetType]) - let funcRetType = applyFree targetType - return (binders, topLevelVarBinder, funcRetType, instanceRetType) - --- | Builds a normalized @Free@ value for the given constructor --- and constructor parameters. -buildNormalformValue - :: TypeMap -- a map to associate types with the appropriate functions to call. - -> Coq.Qualid -- the name of the constructor used to build the value. - -> [(IR.Type, Coq.Qualid) - ] --the types and names of the constructor's parameters - -> Converter Coq.Term -buildNormalformValue nameMap consName = buildNormalformValue' [] - where - -- | Like 'buildNormalformValue', but with an additional parameter to accumulate - -- bound variables. - buildNormalformValue' - :: [Coq.Qualid] -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term - - -- If all components have been normalized, apply the constructor to - -- the normalized components. - buildNormalformValue' boundVars [] = do - args <- mapM (generatePure . Coq.Qualid) (reverse boundVars) - generatePure (Coq.app (Coq.Qualid consName) args) - -- For each component, apply the appropriate function, bind the - -- result and do the remaining computation. - buildNormalformValue' boundVars ((t, varName) : consVars) - = case Map.lookup t nameMap of - -- For recursive or indirectly recursive calls, the type map - -- returns the name of the appropriate function to call. - Just funcName -> do - -- Because the functions work on bare values, the component - -- must be bound (to a fresh variable). - x <- Coq.bare <$> freshCoqIdent freshArgPrefix - -- The result of the normalization will also be bound to a fresh variable. - nx <- Coq.bare <$> freshCoqIdent ("n" ++ freshArgPrefix) - -- Do the rest of the computation with the added bound result. - rhs <- buildNormalformValue' (nx : boundVars) consVars - -- Construct the actual bindings and return the result. - let c = Coq.fun [nx] [Nothing] rhs - let c' = applyBind (Coq.app (Coq.Qualid funcName) [Coq.Qualid x]) c - return $ applyBind (Coq.Qualid varName) (Coq.fun [x] [Nothing] c') - -- If there is no entry in the type map, we can assume that an instance - -- already exists. Therefore, we apply @nf@ to the component to receive - -- a normalized value. - Nothing -> do - nx <- Coq.bare <$> freshCoqIdent ("n" ++ freshArgPrefix) - rhs <- buildNormalformValue' (nx : boundVars) consVars - let c = Coq.fun [nx] [Nothing] rhs - return - $ applyBind (Coq.app (Coq.Qualid (Coq.bare "nf")) - [Coq.Qualid varName]) c - -------------------------------------------------------------------------------- --- Helper functions -- -------------------------------------------------------------------------------- --- Like @showPretty@, but uses the Coq identifiers of the type and its components. -showPrettyType :: IR.Type -> Converter String - --- For a type variable, show its name. -showPrettyType (IR.TypeVar _ varName) = return (showPretty varName) --- For a type constructor, return its Coq identifier as a string. -showPrettyType (IR.TypeCon _ conName) = fromJust . (>>= Coq.unpackQualid) - <$> inEnv (lookupIdent IR.TypeScope conName) --- For a type application, convert both sides and concatenate them. -showPrettyType (IR.TypeApp _ l r) = do - lPretty <- showPrettyType l - rPretty <- showPrettyType r - return (lPretty ++ rPretty) --- Function types should have been converted into variables. -showPrettyType (IR.FuncType _ _ _) - = error "Function types should have been eliminated." - --- Converts a data declaration to a type by applying its constructor to the --- correct number of variables, denoted by underscores. -dataDeclToType :: IR.TypeDecl -> IR.Type -dataDeclToType dataDecl = IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) - (replicate (length (IR.typeDeclArgs dataDecl)) (IR.TypeVar NoSrcSpan "_")) - --- Replaces all variables in a type with fresh variables. -insertFreshVariables :: IR.Type -> Converter IR.Type -insertFreshVariables (IR.TypeVar srcSpan _) = do - freshVar <- freshHaskellIdent freshArgPrefix - return (IR.TypeVar srcSpan freshVar) -insertFreshVariables (IR.TypeApp srcSpan l r) = do - lFresh <- insertFreshVariables l - rFresh <- insertFreshVariables r - return (IR.TypeApp srcSpan lFresh rFresh) --- Type constructors and function types are returned as-is. -insertFreshVariables t = return t - --- Binders for (implicit) Shape and Pos arguments. --- freeArgsBinders = [ {Shape : Type}, {Pos : Shape -> Type} ] -freeArgsBinders :: [Coq.Binder] -freeArgsBinders = genericArgDecls Coq.Implicit - --- Shortcut for the construction of an implicit binder for type variables. --- typeVarBinder [a1, ..., an] = {a1 ... an : Type} -typeVarBinder :: [Coq.Qualid] -> Coq.Binder -typeVarBinder typeVars = Coq.typedBinder Coq.Ungeneralizable Coq.Implicit typeVars Coq.sortType - --- | Constructs a type class constraint. --- > buildConstraint name [a1 ... an] = `{name Shape Pos a1 ... an}. -buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder -buildConstraint className args = Coq.Generalized Coq.Implicit - (Coq.app (Coq.Qualid (Coq.bare className)) (shapeAndPos ++ map Coq.Qualid args)) - --- Shortcut for the application of >>=. -applyBind :: Coq.Term -> Coq.Term -> Coq.Term -applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [mx, f] - --- Given an A, returns Free Shape Pos A -applyFree :: Coq.Term -> Coq.Term -applyFree a = Coq.app (Coq.Qualid Coq.Base.free) (shapeAndPos ++ [a]) - --- | Shape and Pos arguments as Coq terms. -shapeAndPos :: [Coq.Term] -shapeAndPos = [Coq.Qualid Coq.Base.shape, Coq.Qualid Coq.Base.pos] - --- | The shape and position function arguments for the Identity monad --- as a Coq term. -idShapeAndPos :: [Coq.Term] -idShapeAndPos = map Coq.Qualid [Coq.Qualified (Coq.ident "Identity") Coq.Base.shapeIdent - , Coq.Qualified (Coq.ident "Identity") Coq.Base.posIdent] - --- | Converts a type into a Coq type (a term) with the specified --- additional arguments (for example Shape and Pos) and new variables for all --- underscores. --- Similar to convertType, but does not necessarily apply the type constructor --- to Shape and Pos. -toCoqType :: String -- the prefix of the fresh variables - -> [Coq.Term] -- A list of additional - -> IR.Type - -> Converter (Coq.Term, [Coq.Qualid]) -toCoqType varPrefix _ (IR.TypeVar _ _) = do - x <- Coq.bare <$> freshCoqIdent varPrefix - return (Coq.Qualid x, [x]) -toCoqType _ extraArgs (IR.TypeCon _ conName) = do - entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName - return (Coq.app (Coq.Qualid (entryIdent entry)) extraArgs, []) -toCoqType varPrefix extraArgs (IR.TypeApp _ l r) = do - (l', varsl) <- toCoqType varPrefix extraArgs l - (r', varsr) <- toCoqType varPrefix extraArgs r - return (Coq.app l' [r'], varsl ++ varsr) -toCoqType _ _ (IR.FuncType _ _ _) - = error "Function types should have been eliminated." - -------------------------------- --- | Produces @n@ new Coq identifiers (Qualids) with the same prefix. -freshQualids :: Int -> String -> Converter [Coq.Qualid] -freshQualids n prefix = replicateM n (Coq.bare <$> freshCoqIdent prefix) + -- Like @showPretty@, but uses the Coq identifiers of the type and its components. + showPrettyType :: IR.Type -> Converter String + + -- For a type variable, show its name. + showPrettyType (IR.TypeVar _ varName) = return (showPretty varName) + -- For a type constructor, return its Coq identifier as a string. + showPrettyType (IR.TypeCon _ conName) = fromJust . (>>= Coq.unpackQualid) + <$> inEnv (lookupIdent IR.TypeScope conName) + -- For a type application, convert both sides and concatenate them. + showPrettyType (IR.TypeApp _ l r) = do + lPretty <- showPrettyType l + rPretty <- showPrettyType r + return (lPretty ++ rPretty) + -- Function types should have been converted into variables. + showPrettyType (IR.FuncType _ _ _) + = error "Function types should have been eliminated." + + -- Converts a data declaration to a type by applying its constructor to the + -- correct number of variables, denoted by underscores. + dataDeclToType :: IR.TypeDecl -> IR.Type + dataDeclToType dataDecl = IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) + (replicate (length (IR.typeDeclArgs dataDecl)) (IR.TypeVar NoSrcSpan "_")) + + -- Replaces all variables in a type with fresh variables. + insertFreshVariables :: IR.Type -> Converter IR.Type + insertFreshVariables (IR.TypeVar srcSpan _) = do + freshVar <- freshHaskellIdent freshArgPrefix + return (IR.TypeVar srcSpan freshVar) + insertFreshVariables (IR.TypeApp srcSpan l r) = do + lFresh <- insertFreshVariables l + rFresh <- insertFreshVariables r + return (IR.TypeApp srcSpan lFresh rFresh) + -- Type constructors and function types are returned as-is. + insertFreshVariables t = return t + + -- Binders for (implicit) Shape and Pos arguments. + -- freeArgsBinders = [ {Shape : Type}, {Pos : Shape -> Type} ] + freeArgsBinders :: [Coq.Binder] + freeArgsBinders = genericArgDecls Coq.Implicit + + -- Shortcut for the construction of an implicit binder for type variables. + -- typeVarBinder [a1, ..., an] = {a1 ... an : Type} + typeVarBinder :: [Coq.Qualid] -> Coq.Binder + typeVarBinder typeVars = Coq.typedBinder Coq.Ungeneralizable Coq.Implicit typeVars Coq.sortType + + -- | Constructs a type class constraint. + -- > buildConstraint name [a1 ... an] = `{name Shape Pos a1 ... an}. + buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder + buildConstraint className args = Coq.Generalized Coq.Implicit + (Coq.app (Coq.Qualid (Coq.bare className)) (shapeAndPos ++ map Coq.Qualid args)) + + -- Shortcut for the application of >>=. + applyBind :: Coq.Term -> Coq.Term -> Coq.Term + applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [mx, f] + + -- Given an A, returns Free Shape Pos A + applyFree :: Coq.Term -> Coq.Term + applyFree a = Coq.app (Coq.Qualid Coq.Base.free) (shapeAndPos ++ [a]) + + -- | Shape and Pos arguments as Coq terms. + shapeAndPos :: [Coq.Term] + shapeAndPos = [Coq.Qualid Coq.Base.shape, Coq.Qualid Coq.Base.pos] + + -- | The shape and position function arguments for the Identity monad + -- as a Coq term. + idShapeAndPos :: [Coq.Term] + idShapeAndPos = map Coq.Qualid [Coq.Qualified (Coq.ident "Identity") Coq.Base.shapeIdent + , Coq.Qualified (Coq.ident "Identity") Coq.Base.posIdent] + + -- | Converts a type into a Coq type (a term) with the specified + -- additional arguments (for example Shape and Pos) and new variables for all + -- underscores. + -- Similar to convertType, but does not necessarily apply the type constructor + -- to Shape and Pos. + toCoqType :: String -- the prefix of the fresh variables + -> [Coq.Term] -- A list of additional + -> IR.Type + -> Converter (Coq.Term, [Coq.Qualid]) + toCoqType varPrefix _ (IR.TypeVar _ _) = do + x <- Coq.bare <$> freshCoqIdent varPrefix + return (Coq.Qualid x, [x]) + toCoqType _ extraArgs (IR.TypeCon _ conName) = do + entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName + return (Coq.app (Coq.Qualid (entryIdent entry)) extraArgs, []) + toCoqType varPrefix extraArgs (IR.TypeApp _ l r) = do + (l', varsl) <- toCoqType varPrefix extraArgs l + (r', varsr) <- toCoqType varPrefix extraArgs r + return (Coq.app l' [r'], varsl ++ varsr) + toCoqType _ _ (IR.FuncType _ _ _) + = error "Function types should have been eliminated." + + ------------------------------- + -- | Produces @n@ new Coq identifiers (Qualids) with the same prefix. + freshQualids :: Int -> String -> Converter [Coq.Qualid] + freshQualids n prefix = replicateM n (Coq.bare <$> freshCoqIdent prefix) From 4f683f6b2528497793f72427fd56d34ed61a7295 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Mon, 14 Sep 2020 15:48:27 +0200 Subject: [PATCH 042/120] Fix Haddock documentation #158 --- src/lib/FreeC/IR/Syntax/TypeDecl.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib/FreeC/IR/Syntax/TypeDecl.hs b/src/lib/FreeC/IR/Syntax/TypeDecl.hs index b28bc1f0..dac217df 100644 --- a/src/lib/FreeC/IR/Syntax/TypeDecl.hs +++ b/src/lib/FreeC/IR/Syntax/TypeDecl.hs @@ -63,7 +63,7 @@ data ConDecl = ConDecl { conDeclSrcSpan :: SrcSpan } deriving ( Eq, Show ) - -- | Instance to get the name of a constructor declaration. +-- | Instance to get the name of a constructor declaration. instance HasDeclIdent ConDecl where declIdent = conDeclIdent From 8b02b8914fb28bc930fe162c06f64b24506b7645 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 14 Sep 2020 15:49:49 +0200 Subject: [PATCH 043/120] Expand documentation #150 --- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 335 ++++++++++-------- 1 file changed, 193 insertions(+), 142 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index e91dcb64..27584aca 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -217,23 +217,21 @@ convertDataDecl (IR.TypeSynDecl _ _ _ _) -- | Builds instances for all supported typeclasses. -- Currently, only a @Normalform@ instance is generated. -- --- [...] --- -- Suppose we have a type --- @data T a1 ... an = C1 a11 ... a1m1 | ... | Ck ak1 ... akmk@. +-- > data T a1 ... an = C1 a11 ... a1m1 | ... | Ck ak1 ... akmk. -- We wish to generate an instance of class @C@ providing the function -- @f : T a1 ... an -> B@, where @B@ is a type. --- For example, for the @Normalform@ class @f@ would be --- @nf' : T a1 ... an -> Free Shape Pos (T a1 ... an)@. +-- For example, for the @Normalform@ class, @f@ would be +-- > nf' : T a1 ... an -> Free Shape Pos (T a1 ... an). -- -- The generated function has the following basic structure: -- --- @f'T < class-specific binders > (x : T a1 ... an) : B --- := match x with --- | C1 fx11 ... fx1m1 => < buildValue x [fx11, ..., fx1m1] > --- | ... --- | Ck fxk1 ... fxkmk => < buildValue x [fxk1, ..., fxkmk] > --- end. +-- > f'T < class-specific binders > (x : T a1 ... an) : B +-- > := match x with +-- > | C1 fx11 ... fx1m1 => < buildValue x [fx11, ..., fx1m1] > +-- > | ... +-- > | Ck fxk1 ... fxkmk => < buildValue x [fxk1, ..., fxkmk] > +-- > end. -- -- @buildValue x [fxi1, ..., fximi]@ represents class-specific code that -- actually constructs a value of type @B@ when given @x@ and the @@ -243,17 +241,17 @@ convertDataDecl (IR.TypeSynDecl _ _ _ _) -- @data List a = Nil | Cons a (List a)@, -- the function would look as follows. -- --- @nf'List_ {Shape : Type} {Pos : Shape -> Type} --- {a b : Type} `{Normalform Shape Pos a b} --- (x : List Shape Pos a) --- : Free Shape Pos (List Identity.Shape Identity.Pos b) --- := match x with --- | nil => pure nil --- | cons fx_0 fx_1 => nf fx_0 >>= fun nx_0 => --- fx_1 >>= fun x_1 => --- nf'List x_1 >>= fun nx_1 => --- pure (cons (pure nx_0) (pure nx_1)) --- end. +-- > nf'List_ {Shape : Type} {Pos : Shape -> Type} +-- > {a b : Type} `{Normalform Shape Pos a b} +-- > (x : List Shape Pos a) +-- > : Free Shape Pos (List Identity.Shape Identity.Pos b) +-- > := match x with +-- > | nil => pure nil +-- > | cons fx_0 fx_1 => nf fx_0 >>= fun nx_0 => +-- > fx_1 >>= fun x_1 => +-- > nf'List x_1 >>= fun nx_1 => +-- > pure (cons (pure nx_0) (pure nx_1)) +-- > end. -- -- Typically, @buildValue@ will use the class function @f@ on all components, -- then reconstruct the value using the results of those function calls. @@ -381,7 +379,10 @@ generateTypeclassInstances dataDecls = do :: -- A map to map occurrences of the top-level types to recursive -- function calls. - TypeMap -> IR.Type -> [IR.Type] -> Converter (Coq.FixBody, Coq.Sentence) + TypeMap + -> IR.Type + -> [IR.Type] + -> Converter (Coq.FixBody, Coq.Sentence) buildFixBodyAndInstance topLevelMap t recTypes = do -- Locally visible definitions are defined in a local environment. (fixBody, typeLevelMap, binders, instanceRetType) <- localEnv $ do @@ -509,85 +510,104 @@ generateTypeclassInstances dataDecls = do ------------------------------------------------------------------------------- -- Functions to produce Normalform instances -- ------------------------------------------------------------------------------- + -- | The name of the Normalform class. normalformClassName :: String normalformClassName = "Normalform" + -- | The name of the Normalform class function. normalformFuncName :: String normalformFuncName = "nf'" + -- | The binders and return types for the Normalform class function and instance. nfBindersAndReturnType - :: IR.Type - -> Coq.Qualid - -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) + :: + -- The type for which we are defining an instance. + IR.Type + -> Coq.Qualid + -> Converter + ( [Coq.Binder] -- Type variable binders and Normalform constraints. + , Coq.Binder -- Binder for the argument of type @t@. + , Coq.Term -- Return type of nf'. + , Coq.Term + ) -- Return type of the Normalform instance. + nfBindersAndReturnType t varName = do - (sourceType, sourceVars) <- toCoqType "a" shapeAndPos t - (targetType, targetVars) <- toCoqType "b" idShapeAndPos t - let constraints = map (buildConstraint normalformClassName) - (zipWith (\v1 v2 -> [v1, v2]) sourceVars targetVars) - let varBinders - = [typeVarBinder (sourceVars ++ targetVars) | not (null sourceVars)] - let binders = varBinders ++ constraints - let topLevelVarBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit varName sourceType - let instanceRetType = Coq.app (Coq.Qualid (Coq.bare normalformClassName)) - (shapeAndPos ++ [sourceType, targetType]) - let funcRetType = applyFree targetType - return (binders, topLevelVarBinder, funcRetType, instanceRetType) + -- For each type variable in the type, generate two type variables. + -- One represents the type's variable itself, the other the result + -- type of the normalization. + -- The type is transformed to a Coq type twice, once with Shape and + -- Pos as arguments for the original type, once with Identity.Shape + -- and Identity.Pos as arguments for the normalized result type. + (sourceType, sourceVars) <- toCoqType "a" shapeAndPos t + (targetType, targetVars) <- toCoqType "b" idShapeAndPos t + -- For each type variable ai, build a constraint + -- `{Normalform Shape Pos ai bi}. + let constraints = map (buildConstraint normalformClassName) + (zipWith (\v1 v2 -> [v1, v2]) sourceVars targetVars) + let varBinders + = [typeVarBinder (sourceVars ++ targetVars) | not (null sourceVars)] + let binders = varBinders ++ constraints + -- Create an explicit argument binder for the value to be normalized. + let topLevelVarBinder + = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit varName sourceType + let instanceRetType = Coq.app (Coq.Qualid (Coq.bare normalformClassName)) + (shapeAndPos ++ [sourceType, targetType]) + let funcRetType = applyFree targetType + return (binders, topLevelVarBinder, funcRetType, instanceRetType) -- | Builds a normalized @Free@ value for the given constructor - -- and constructor parameters. + -- and constructor arguments. buildNormalformValue - -- A map to associate types with the appropriate functions to call. - :: TypeMap - -- The name of the constructor used to build the value. - -> Coq.Qualid - -- The types and names of the constructor's parameters. - -> [(IR.Type, Coq.Qualid)] - -> Converter Coq.Term + :: + -- A map to associate types with the appropriate functions to call. + TypeMap + -> Coq.Qualid + -> [(IR.Type, Coq.Qualid)] + -> Converter Coq.Term buildNormalformValue nameMap consName = buildNormalformValue' [] - where - -- | Like 'buildNormalformValue', but with an additional parameter to accumulate - -- bound variables. - buildNormalformValue' - :: [Coq.Qualid] -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term - - -- If all components have been normalized, apply the constructor to - -- the normalized components. - buildNormalformValue' boundVars [] = do - args <- mapM (generatePure . Coq.Qualid) (reverse boundVars) - generatePure (Coq.app (Coq.Qualid consName) args) - -- For each component, apply the appropriate function, bind the - -- result and do the remaining computation. - buildNormalformValue' boundVars ((t, varName) : consVars) - = case Map.lookup t nameMap of - -- For recursive or indirectly recursive calls, the type map - -- returns the name of the appropriate function to call. - Just funcName -> do - -- Because the functions work on bare values, the component - -- must be bound (to a fresh variable). - x <- Coq.bare <$> freshCoqIdent freshArgPrefix - -- The result of the normalization will also be bound to a fresh variable. - nx <- Coq.bare <$> freshCoqIdent ("n" ++ freshArgPrefix) - -- Do the rest of the computation with the added bound result. - rhs <- buildNormalformValue' (nx : boundVars) consVars - -- Construct the actual bindings and return the result. - let c = Coq.fun [nx] [Nothing] rhs - let c' = applyBind (Coq.app (Coq.Qualid funcName) [Coq.Qualid x]) c - return $ applyBind (Coq.Qualid varName) (Coq.fun [x] [Nothing] c') - -- If there is no entry in the type map, we can assume that an instance - -- already exists. Therefore, we apply @nf@ to the component to receive - -- a normalized value. - Nothing -> do - nx <- Coq.bare <$> freshCoqIdent ("n" ++ freshArgPrefix) - rhs <- buildNormalformValue' (nx : boundVars) consVars - let c = Coq.fun [nx] [Nothing] rhs - return - $ applyBind (Coq.app (Coq.Qualid (Coq.bare "nf")) - [Coq.Qualid varName]) c + where + -- | Like 'buildNormalformValue', but with an additional parameter to accumulate + -- bound variables. + buildNormalformValue' + :: [Coq.Qualid] -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term + + -- If all components have been normalized, apply the constructor to + -- the normalized components. + buildNormalformValue' boundVars [] = do + args <- mapM (generatePure . Coq.Qualid) (reverse boundVars) + generatePure (Coq.app (Coq.Qualid consName) args) + -- For each component, apply the appropriate function, bind the + -- result and do the remaining computation. + buildNormalformValue' boundVars ((t, varName) : consVars) + = case Map.lookup t nameMap of + -- For recursive or indirectly recursive calls, the type map + -- returns the name of the appropriate function to call. + Just funcName -> do + -- Because the functions work on bare values, the component + -- must be bound (to a fresh variable). + x <- Coq.bare <$> freshCoqIdent freshArgPrefix + -- The result of the normalization will also be bound to a fresh variable. + nx <- Coq.bare <$> freshCoqIdent ("n" ++ freshArgPrefix) + -- Do the rest of the computation with the added bound result. + rhs <- buildNormalformValue' (nx : boundVars) consVars + -- Construct the actual bindings and return the result. + let c = Coq.fun [nx] [Nothing] rhs + let c' = applyBind (Coq.app (Coq.Qualid funcName) [Coq.Qualid x]) c + return $ applyBind (Coq.Qualid varName) (Coq.fun [x] [Nothing] c') + -- If there is no entry in the type map, we can assume that an instance + -- already exists. Therefore, we apply @nf@ to the component to receive + -- a normalized value. + Nothing -> do + nx <- Coq.bare <$> freshCoqIdent ("n" ++ freshArgPrefix) + rhs <- buildNormalformValue' (nx : boundVars) consVars + let c = Coq.fun [nx] [Nothing] rhs + return + $ applyBind + (Coq.app (Coq.Qualid (Coq.bare "nf")) [Coq.Qualid varName]) c ------------------------------------------------------------------------------- -- Helper functions -- ------------------------------------------------------------------------------- - -- | Creates an entry with a unique name for each of the given types and -- inserts them into the given map. nameFunctionsAndInsert :: String -> TypeMap -> [IR.Type] -> Converter TypeMap @@ -606,44 +626,67 @@ generateTypeclassInstances dataDecls = do prettyType <- showPrettyType t freshCoqIdent (prefix ++ prettyType) - -- This function collects all fully-applied type constructors - -- of arity at least 1 (including their arguments) that occur in the given type. - -- All arguments that do not contain occurrences of the types for which - -- we are defining an instance are replaced by the type variable "_". - -- The resulting list contains (in reverse topological order) exactly all - -- types for which we must define a separate function in the instance - -- definition, where all occurrences of "_" represent the polymorphic - -- components of the function. + -- | Collects all fully-applied type constructors + -- of arity at least 1 (including their arguments) that occur in the given + -- type. All arguments that do not contain occurrences of the types for + -- which we are defining an instance are replaced by the type variable "_". + -- The resulting list contains (in reverse topological order) exactly all + -- types for which we must define a separate function in the instance + -- definition, where all occurrences of "_" represent the polymorphic + -- components of the function. collectSubTypes :: IR.Type -> [IR.Type] collectSubTypes = collectFullyAppliedTypes True - - collectFullyAppliedTypes :: Bool -> IR.Type -> [IR.Type] - collectFullyAppliedTypes fullApplication t@(IR.TypeApp _ l r) - | fullApplication = stripType t - : collectFullyAppliedTypes False l ++ collectFullyAppliedTypes True r - | otherwise - = collectFullyAppliedTypes False l ++ collectFullyAppliedTypes True r - -- Type variables, function types and type constructors with arity 0 are not - -- collected. - collectFullyAppliedTypes _ _ = [] - - -- returns the same type with all 'don't care' types replaced by the variable "_" + where + -- | Like 'collectSubTypes', but with an additional flag to denote whether + -- @t@ is a full application of a type constructor, e.g. @Pair Int Bool@, + -- or a partial application, e.g. @Pair Int@. + -- Only full applications are collected. + collectFullyAppliedTypes :: Bool -> IR.Type -> [IR.Type] + collectFullyAppliedTypes fullApplication t@(IR.TypeApp _ l r) + -- The left-hand side of a type application is the partial + -- application of a type constructor. + -- The right-hand side is a fully-applied type constructor, + -- a variable or a function type. + = let remainingTypes = collectFullyAppliedTypes False l + ++ collectFullyAppliedTypes True r + in if fullApplication + then stripType t : remainingTypes + else remainingTypes + -- Type variables, function types and type constructors with arity 0 are not + -- collected. + collectFullyAppliedTypes _ _ = [] + + -- | Returns the same type with all type expressions that do not contain one + -- of the type constructors for which we are defining instances replaced + -- by the type variable "_". stripType :: IR.Type -> IR.Type stripType t = stripType' t False - - stripType' :: IR.Type -> Bool -> IR.Type - stripType' (IR.TypeCon _ conName) flag - | flag || conName `elem` conNames = IR.TypeCon NoSrcSpan conName - | otherwise = IR.TypeVar NoSrcSpan "_" - stripType' (IR.TypeApp _ l r) flag = case stripType' r False of - r'@(IR.TypeVar _ _) -> case stripType' l flag of - (IR.TypeVar _ _) -> IR.TypeVar NoSrcSpan "_" -- makes sure that Don't cares are squashed. - l' -> IR.TypeApp NoSrcSpan l' r' - r' -> IR.TypeApp NoSrcSpan (stripType' l True) r' - -- Type variables and function types are not relevant and are replaced by "_". - stripType' _ _ = IR.TypeVar NoSrcSpan "_" - - -- Like @showPretty@, but uses the Coq identifiers of the type and its components. + where + -- | Like 'stripType', but with an additional flag to denote whether an + -- occurrence of a relevant type was found in an argument of a type + -- application. + -- This is necessary so that, for example, @Pair Bool t@ is not + -- translated to @_ t@, but to @Pair _ t@. + stripType' :: IR.Type -> Bool -> IR.Type + + -- + stripType' (IR.TypeCon _ conName) flag + | flag || conName `elem` conNames = IR.TypeCon NoSrcSpan conName + | otherwise = IR.TypeVar NoSrcSpan "_" + -- For a type application, check if a relevant type occurs in @r@. + stripType' (IR.TypeApp _ l r) flag = case stripType' r False of + -- If not, check if a relevant type occurs in @l@, and otherwise + -- replace the whole expression with an underscore. + r'@(IR.TypeVar _ _) -> case stripType' l flag of + IR.TypeVar _ _ -> IR.TypeVar NoSrcSpan "_" + l' -> IR.TypeApp NoSrcSpan l' r' + -- If a relevant type does occur in @r@, the type application must + -- be preserved, so only its arguments are stripped.´ + r' -> IR.TypeApp NoSrcSpan (stripType' l True) r' + -- Type variables and function types are not relevant and are replaced by "_". + stripType' _ _ = IR.TypeVar NoSrcSpan "_" + + -- | Like @showPretty@, but uses the Coq identifiers of the type and its components. showPrettyType :: IR.Type -> Converter String -- For a type variable, show its name. @@ -660,13 +703,13 @@ generateTypeclassInstances dataDecls = do showPrettyType (IR.FuncType _ _ _) = error "Function types should have been eliminated." - -- Converts a data declaration to a type by applying its constructor to the - -- correct number of variables, denoted by underscores. + -- | Converts a data declaration to a type by applying its constructor to the + -- correct number of variables, denoted by underscores. dataDeclToType :: IR.TypeDecl -> IR.Type dataDeclToType dataDecl = IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) (replicate (length (IR.typeDeclArgs dataDecl)) (IR.TypeVar NoSrcSpan "_")) - -- Replaces all variables in a type with fresh variables. + -- | Replaces all variables in a type with fresh variables. insertFreshVariables :: IR.Type -> Converter IR.Type insertFreshVariables (IR.TypeVar srcSpan _) = do freshVar <- freshHaskellIdent freshArgPrefix @@ -678,27 +721,29 @@ generateTypeclassInstances dataDecls = do -- Type constructors and function types are returned as-is. insertFreshVariables t = return t - -- Binders for (implicit) Shape and Pos arguments. - -- freeArgsBinders = [ {Shape : Type}, {Pos : Shape -> Type} ] + -- | Binders for (implicit) Shape and Pos arguments. + -- > freeArgsBinders = [ {Shape : Type}, {Pos : Shape -> Type} ] freeArgsBinders :: [Coq.Binder] freeArgsBinders = genericArgDecls Coq.Implicit - -- Shortcut for the construction of an implicit binder for type variables. - -- typeVarBinder [a1, ..., an] = {a1 ... an : Type} + -- | Shortcut for the construction of an implicit binder for type variables. + -- > typeVarBinder [a1, ..., an] = {a1 ... an : Type} typeVarBinder :: [Coq.Qualid] -> Coq.Binder - typeVarBinder typeVars = Coq.typedBinder Coq.Ungeneralizable Coq.Implicit typeVars Coq.sortType + typeVarBinder typeVars + = Coq.typedBinder Coq.Ungeneralizable Coq.Implicit typeVars Coq.sortType -- | Constructs a type class constraint. -- > buildConstraint name [a1 ... an] = `{name Shape Pos a1 ... an}. buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder buildConstraint className args = Coq.Generalized Coq.Implicit - (Coq.app (Coq.Qualid (Coq.bare className)) (shapeAndPos ++ map Coq.Qualid args)) + (Coq.app (Coq.Qualid (Coq.bare className)) + (shapeAndPos ++ map Coq.Qualid args)) - -- Shortcut for the application of >>=. + -- | Shortcut for the application of >>=. applyBind :: Coq.Term -> Coq.Term -> Coq.Term applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [mx, f] - -- Given an A, returns Free Shape Pos A + -- | Given an A, returns Free Shape Pos A applyFree :: Coq.Term -> Coq.Term applyFree a = Coq.app (Coq.Qualid Coq.Base.free) (shapeAndPos ++ [a]) @@ -709,32 +754,38 @@ generateTypeclassInstances dataDecls = do -- | The shape and position function arguments for the Identity monad -- as a Coq term. idShapeAndPos :: [Coq.Term] - idShapeAndPos = map Coq.Qualid [Coq.Qualified (Coq.ident "Identity") Coq.Base.shapeIdent - , Coq.Qualified (Coq.ident "Identity") Coq.Base.posIdent] + idShapeAndPos = map Coq.Qualid + [ Coq.Qualified (Coq.ident "Identity") Coq.Base.shapeIdent + , Coq.Qualified (Coq.ident "Identity") Coq.Base.posIdent + ] -- | Converts a type into a Coq type (a term) with the specified - -- additional arguments (for example Shape and Pos) and new variables for all - -- underscores. - -- Similar to convertType, but does not necessarily apply the type constructor - -- to Shape and Pos. - toCoqType :: String -- the prefix of the fresh variables - -> [Coq.Term] -- A list of additional - -> IR.Type + -- additional arguments (for example Shape and Pos) and fresh Coq + -- identifiers for all underscores. + -- Returns a pair of the result term and a list of the fresh variables. + toCoqType :: String -- The prefix of the fresh variables. + -> [Coq.Term] -- A list of additional arguments, e.g. Shape and Pos. + -> IR.Type -- The type to convert. -> Converter (Coq.Term, [Coq.Qualid]) + + -- A type variable is translated into a fresh type variable. toCoqType varPrefix _ (IR.TypeVar _ _) = do x <- Coq.bare <$> freshCoqIdent varPrefix return (Coq.Qualid x, [x]) + -- A type constructor is applied to the given arguments. toCoqType _ extraArgs (IR.TypeCon _ conName) = do entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName return (Coq.app (Coq.Qualid (entryIdent entry)) extraArgs, []) + -- For a type application, both arguments are translated recursively + -- and the collected variables are combined. toCoqType varPrefix extraArgs (IR.TypeApp _ l r) = do (l', varsl) <- toCoqType varPrefix extraArgs l (r', varsr) <- toCoqType varPrefix extraArgs r return (Coq.app l' [r'], varsl ++ varsr) + -- Function types were removed by 'stripType'. toCoqType _ _ (IR.FuncType _ _ _) = error "Function types should have been eliminated." - ------------------------------- - -- | Produces @n@ new Coq identifiers (Qualids) with the same prefix. + -- | Produces @n@ new Coq identifiers (Qualids) with the same prefix. freshQualids :: Int -> String -> Converter [Coq.Qualid] freshQualids n prefix = replicateM n (Coq.bare <$> freshCoqIdent prefix) From 4ad8bd2a1a7db0d70248bf4e4c1d9366de04d6ef Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Mon, 14 Sep 2020 15:50:09 +0200 Subject: [PATCH 044/120] Format code #74 --- .../FreeC/Frontend/Haskell/SimplifierTests.hs | 21 ++++++++++--------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/src/test/FreeC/Frontend/Haskell/SimplifierTests.hs b/src/test/FreeC/Frontend/Haskell/SimplifierTests.hs index 1b35338d..3391e185 100644 --- a/src/test/FreeC/Frontend/Haskell/SimplifierTests.hs +++ b/src/test/FreeC/Frontend/Haskell/SimplifierTests.hs @@ -1,24 +1,24 @@ -- | This module contains tests for "FreeC.Frontend.Haskell.Simplifier". -module FreeC.Frontend.Haskell.SimplifierTests (testSimplifier) where +module FreeC.Frontend.Haskell.SimplifierTests ( testSimplifier ) where -import Control.Monad ( (>=>) ) -import Test.Hspec +import Control.Monad ( (>=>) ) +import Test.Hspec -import qualified FreeC.IR.Syntax as IR import FreeC.Frontend.Haskell.Parser import FreeC.Frontend.Haskell.Simplifier +import FreeC.IR.SrcSpan +import qualified FreeC.IR.Syntax as IR import FreeC.Monad.Class.Testable import FreeC.Test.Expectations import FreeC.Test.Parser -import FreeC.IR.SrcSpan ------------------------------------------------------------------------------- -- Utility functions -- ------------------------------------------------------------------------------- - -- | Parses a Haskell expression and converts it to IR. parseAndSimplifyExpr :: String -> Simplifier IR.Expr -parseAndSimplifyExpr = (parseHaskell . mkSrcFile "") >=> simplifyExpr +parseAndSimplifyExpr = (parseHaskell . mkSrcFile "") + >=> simplifyExpr -- | Parses the given Haskell and IR expressions, converts the Haskell -- expression to IR . @@ -31,7 +31,6 @@ shouldSimplifyExpr input expectedOutput = do ------------------------------------------------------------------------------- -- Tests -- ------------------------------------------------------------------------------- - -- | Test group for "FreeC.Frontend.Haskell.Simplifier" tests. testSimplifier :: Spec testSimplifier = describe "FreeC.Frontend.Haskell.Simplifier" $ do @@ -40,5 +39,7 @@ testSimplifier = describe "FreeC.Frontend.Haskell.Simplifier" $ do -- | Test group for 'simplifyExpr' tests. testSimplifyExpr :: Spec testSimplifyExpr = context "simplifyExpr" $ do - it "simplifies single variable pattern case expression to lambda abstractions" $ shouldSucceedWith $ do - "case e of { x -> e' }" `shouldSimplifyExpr` "(\\x -> e') e" + it "simplifies single variable pattern case expression to lambda abstractions" + $ shouldSucceedWith + $ do + "case e of { x -> e' }" `shouldSimplifyExpr` "(\\x -> e') e" From a17351bde4fe48ad8965318b55ea2141e51575e5 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Mon, 14 Sep 2020 15:58:11 +0200 Subject: [PATCH 045/120] Fix issues that resulted from merge #199 --- free-compiler.cabal | 3 +-- src/lib/FreeC/Backend/Agda/Converter/Module.hs | 2 +- src/lib/FreeC/Pass/DefineDeclPass.hs | 4 ++-- src/lib/FreeC/Pass/PragmaPass.hs | 2 -- src/lib/FreeC/Pipeline.hs | 2 +- ...AnalysisPassTests.hs => EffectAnalysisPassTests.hs} | 10 ++++------ src/test/FreeC/PipelineTests.hs | 5 +++-- 7 files changed, 12 insertions(+), 16 deletions(-) rename src/test/FreeC/Pass/{PartialityAnalysisPassTests.hs => EffectAnalysisPassTests.hs} (94%) diff --git a/free-compiler.cabal b/free-compiler.cabal index 51def865..e80a6358 100644 --- a/free-compiler.cabal +++ b/free-compiler.cabal @@ -177,7 +177,6 @@ library freec-internal , FreeC.Pass.ImplicitPreludePass , FreeC.Pass.ImportPass , FreeC.Pass.KindCheckPass - , FreeC.Pass.PartialityAnalysisPass , FreeC.Pass.PragmaPass , FreeC.Pass.QualifierPass , FreeC.Pass.ResolverPass @@ -253,10 +252,10 @@ test-suite freec-unit-tests , FreeC.Monad.Class.Testable , FreeC.Monad.ReporterTests , FreeC.Pass.CompletePatternPassTests + , FreeC.Pass.EffectAnalysisPassTests , FreeC.Pass.EtaConversionPassTests , FreeC.Pass.ExportPassTests , FreeC.Pass.KindCheckPassTests - , FreeC.Pass.PartialityAnalysisPassTests , FreeC.Pass.ResolverPassTests , FreeC.Pass.TypeInferencePassTests , FreeC.PipelineTests diff --git a/src/lib/FreeC/Backend/Agda/Converter/Module.hs b/src/lib/FreeC/Backend/Agda/Converter/Module.hs index 51d79ad9..15041709 100644 --- a/src/lib/FreeC/Backend/Agda/Converter/Module.hs +++ b/src/lib/FreeC/Backend/Agda/Converter/Module.hs @@ -18,7 +18,7 @@ import FreeC.Monad.Converter -- | Converts an IR module to an Agda declaration. convertModule :: IR.Module -> Converter Agda.Declaration -convertModule (IR.Module _ name importDecls typeDecls _ modPragmas funcDecls) +convertModule (IR.Module _ name importDecls typeDecls _ _ funcDecls) = Agda.moduleDecl (convertModName name) <$> getAp (importDecls' <> typeDecls' <> funcDecls') where diff --git a/src/lib/FreeC/Pass/DefineDeclPass.hs b/src/lib/FreeC/Pass/DefineDeclPass.hs index 65bc455f..0c84809e 100644 --- a/src/lib/FreeC/Pass/DefineDeclPass.hs +++ b/src/lib/FreeC/Pass/DefineDeclPass.hs @@ -3,8 +3,8 @@ -- environment. -- -- Subsequent passes can still modify entries added by this pass. --- For example, whether functions are partial or not is determined after --- this pass (See "FreeC.Pass.PartialityAnalysisPass"). +-- For example, which effects are used by which functions is determined +-- after this pass (see "FreeC.Pass.EffectAnalysisPass"). -- -- = Specification -- diff --git a/src/lib/FreeC/Pass/PragmaPass.hs b/src/lib/FreeC/Pass/PragmaPass.hs index 00f1b089..11b1fe7a 100644 --- a/src/lib/FreeC/Pass/PragmaPass.hs +++ b/src/lib/FreeC/Pass/PragmaPass.hs @@ -25,8 +25,6 @@ -- function declaration or the function does not have an argument with -- the specified name or at the specified position, a fatal error is -- reported. - - module FreeC.Pass.PragmaPass ( pragmaPass ) where import Data.List ( find, findIndex ) diff --git a/src/lib/FreeC/Pipeline.hs b/src/lib/FreeC/Pipeline.hs index 64d4152f..0e60a589 100644 --- a/src/lib/FreeC/Pipeline.hs +++ b/src/lib/FreeC/Pipeline.hs @@ -20,9 +20,9 @@ import FreeC.Pass.ExportPass import FreeC.Pass.ImplicitPreludePass import FreeC.Pass.ImportPass import FreeC.Pass.KindCheckPass +import FreeC.Pass.PragmaPass import FreeC.Pass.QualifierPass import FreeC.Pass.ResolverPass -import FreeC.Pass.PragmaPass import FreeC.Pass.TypeInferencePass import FreeC.Pass.TypeSignaturePass diff --git a/src/test/FreeC/Pass/PartialityAnalysisPassTests.hs b/src/test/FreeC/Pass/EffectAnalysisPassTests.hs similarity index 94% rename from src/test/FreeC/Pass/PartialityAnalysisPassTests.hs rename to src/test/FreeC/Pass/EffectAnalysisPassTests.hs index 4c63722c..8ab31d9d 100644 --- a/src/test/FreeC/Pass/PartialityAnalysisPassTests.hs +++ b/src/test/FreeC/Pass/EffectAnalysisPassTests.hs @@ -1,7 +1,5 @@ --- | This module contains tests for "FreeC.Pass.PartialityAnalysisPass". -module FreeC.Pass.PartialityAnalysisPassTests - ( testPartialityAnalysisPass - ) where +-- | This module contains tests for "FreeC.Pass.EffectAnalysisPassTests". +module FreeC.Pass.EffectAnalysisPassTests ( testEffectAnalysisPass ) where import Control.Monad.Extra ( zipWithM_ ) import Test.Hspec @@ -56,8 +54,8 @@ shouldBePartialWith setExpectation inputs = do -- Tests -- ------------------------------------------------------------------------------- -- | Test group for 'Partiality' effect of 'effectAnalysisPass' tests. -testPartialityAnalysisPass :: Spec -testPartialityAnalysisPass = describe "FreeC.Pass.PartialityAnalysisPass" $ do +testEffectAnalysisPass :: Spec +testEffectAnalysisPass = describe "FreeC.Pass.EffectAnalysisPass" $ do it "does not classify non-partial functions as partial" $ shouldSucceedWith $ do diff --git a/src/test/FreeC/PipelineTests.hs b/src/test/FreeC/PipelineTests.hs index 13e0be27..e9dba831 100644 --- a/src/test/FreeC/PipelineTests.hs +++ b/src/test/FreeC/PipelineTests.hs @@ -5,10 +5,10 @@ module FreeC.PipelineTests ( testPipeline ) where import Test.Hspec import FreeC.Pass.CompletePatternPassTests +import FreeC.Pass.EffectAnalysisPassTests import FreeC.Pass.EtaConversionPassTests import FreeC.Pass.ExportPassTests import FreeC.Pass.KindCheckPassTests -import FreeC.Pass.PartialityAnalysisPassTests import FreeC.Pass.ResolverPassTests import FreeC.Pass.TypeInferencePassTests @@ -16,9 +16,10 @@ import FreeC.Pass.TypeInferencePassTests testPipeline :: Spec testPipeline = do testCompletePatternPass + testEffectAnalysisPass testEtaConversionPass testExportPass testKindCheckPass - testPartialityAnalysisPass + testEffectAnalysisPass testResolverPass testTypeInferencePass From cc75a40ce0329fab1e75d17e6f96739a05779cfb Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 14 Sep 2020 16:04:09 +0200 Subject: [PATCH 046/120] Add Coq comment above class instances #150 --- src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 27584aca..1a52abd0 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -370,9 +370,11 @@ generateTypeclassInstances dataDecls = do (fixBodies, instances) <- mapAndUnzipM (uncurry (buildFixBodyAndInstance topLevelMap)) (zip declTypes recTypeList) - return - $ Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) - : instances + return $ + Coq.comment (className ++ " instance" ++ ['s' | length dataDecls > 1] ++ " for " + ++ showPretty (map IR.typeDeclName dataDecls)) + : Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) + : instances where -- Constructs the class function and class instance for a single type. buildFixBodyAndInstance From d48a234a12ff09b96896d4019f69b81b2ba7011c Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 14 Sep 2020 16:19:55 +0200 Subject: [PATCH 047/120] Add constant for underscore variable #150 --- src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 1a52abd0..c3af1426 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -628,6 +628,11 @@ generateTypeclassInstances dataDecls = do prettyType <- showPrettyType t freshCoqIdent (prefix ++ prettyType) + -- | A type variable that represents irrelevant parts of a type expression. + -- Represented by an underscore. + placeholderVar :: IR.Type + placeholderVar = IR.TypeVar NoSrcSpan "_" + -- | Collects all fully-applied type constructors -- of arity at least 1 (including their arguments) that occur in the given -- type. All arguments that do not contain occurrences of the types for @@ -674,19 +679,19 @@ generateTypeclassInstances dataDecls = do -- stripType' (IR.TypeCon _ conName) flag | flag || conName `elem` conNames = IR.TypeCon NoSrcSpan conName - | otherwise = IR.TypeVar NoSrcSpan "_" + | otherwise = placeholderVar -- For a type application, check if a relevant type occurs in @r@. stripType' (IR.TypeApp _ l r) flag = case stripType' r False of -- If not, check if a relevant type occurs in @l@, and otherwise -- replace the whole expression with an underscore. r'@(IR.TypeVar _ _) -> case stripType' l flag of - IR.TypeVar _ _ -> IR.TypeVar NoSrcSpan "_" + IR.TypeVar _ _ -> placeholderVar l' -> IR.TypeApp NoSrcSpan l' r' -- If a relevant type does occur in @r@, the type application must -- be preserved, so only its arguments are stripped.´ r' -> IR.TypeApp NoSrcSpan (stripType' l True) r' -- Type variables and function types are not relevant and are replaced by "_". - stripType' _ _ = IR.TypeVar NoSrcSpan "_" + stripType' _ _ = placeholderVar -- | Like @showPretty@, but uses the Coq identifiers of the type and its components. showPrettyType :: IR.Type -> Converter String @@ -709,7 +714,7 @@ generateTypeclassInstances dataDecls = do -- correct number of variables, denoted by underscores. dataDeclToType :: IR.TypeDecl -> IR.Type dataDeclToType dataDecl = IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) - (replicate (length (IR.typeDeclArgs dataDecl)) (IR.TypeVar NoSrcSpan "_")) + (replicate (length (IR.typeDeclArgs dataDecl)) placeholderVar) -- | Replaces all variables in a type with fresh variables. insertFreshVariables :: IR.Type -> Converter IR.Type From 7a2d4a5777e4e257a537487e79a3ea8c2ad7656e Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 14 Sep 2020 16:45:54 +0200 Subject: [PATCH 048/120] Format code with Floskell #150 --- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 23 ++++++++----------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index c3af1426..682c3c69 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -370,21 +370,21 @@ generateTypeclassInstances dataDecls = do (fixBodies, instances) <- mapAndUnzipM (uncurry (buildFixBodyAndInstance topLevelMap)) (zip declTypes recTypeList) - return $ - Coq.comment (className ++ " instance" ++ ['s' | length dataDecls > 1] ++ " for " - ++ showPretty (map IR.typeDeclName dataDecls)) - : Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) - : instances + return + $ Coq.comment (className + ++ " instance" + ++ ['s' | length dataDecls > 1] + ++ " for " + ++ showPretty (map IR.typeDeclName dataDecls)) + : Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) + : instances where -- Constructs the class function and class instance for a single type. buildFixBodyAndInstance :: -- A map to map occurrences of the top-level types to recursive -- function calls. - TypeMap - -> IR.Type - -> [IR.Type] - -> Converter (Coq.FixBody, Coq.Sentence) + TypeMap -> IR.Type -> [IR.Type] -> Converter (Coq.FixBody, Coq.Sentence) buildFixBodyAndInstance topLevelMap t recTypes = do -- Locally visible definitions are defined in a local environment. (fixBody, typeLevelMap, binders, instanceRetType) <- localEnv $ do @@ -562,10 +562,7 @@ generateTypeclassInstances dataDecls = do buildNormalformValue :: -- A map to associate types with the appropriate functions to call. - TypeMap - -> Coq.Qualid - -> [(IR.Type, Coq.Qualid)] - -> Converter Coq.Term + TypeMap -> Coq.Qualid -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term buildNormalformValue nameMap consName = buildNormalformValue' [] where -- | Like 'buildNormalformValue', but with an additional parameter to accumulate From e8201b67a4afe58807b0157353752937ed9ea42a Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 14 Sep 2020 16:55:17 +0200 Subject: [PATCH 049/120] Format Coq.Base #150 --- src/lib/FreeC/Backend/Coq/Base.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/lib/FreeC/Backend/Coq/Base.hs b/src/lib/FreeC/Backend/Coq/Base.hs index 39e5acd6..80cb3631 100644 --- a/src/lib/FreeC/Backend/Coq/Base.hs +++ b/src/lib/FreeC/Backend/Coq/Base.hs @@ -105,7 +105,6 @@ freeArgs = [ (shape, Coq.Sort Coq.Type) , (pos, Coq.Arrow (Coq.Qualid shape) (Coq.Sort Coq.Type)) ] - ------------------------------------------------------------------------------- -- Partiality -- ------------------------------------------------------------------------------- From 6abb81290d21563fa846d25c480649cd2595c1d6 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 14 Sep 2020 19:13:34 +0200 Subject: [PATCH 050/120] Add some examples using Error to the normalization tests #119 --- base/coq/Free/Handlers.v | 14 +++++++------- example/Base/NormalizationTests.v | 24 ++++++++++++++++++++---- 2 files changed, 27 insertions(+), 11 deletions(-) diff --git a/base/coq/Free/Handlers.v b/base/coq/Free/Handlers.v index 4f281040..c24630f7 100644 --- a/base/coq/Free/Handlers.v +++ b/base/coq/Free/Handlers.v @@ -42,7 +42,7 @@ Section OneEffect. Definition SErrId := Comb.Shape (Error.Shape string) Identity.Shape. Definition PErrId := Comb.Pos (@Error.Pos string) Identity.Pos. - Definition handleError (A B : Type) + Definition handleError {A B : Type} `{Normalform SErrId PErrId A B} (p : Free SErrId PErrId A) : (B + string) := run (runError (nf p)). @@ -148,7 +148,7 @@ Section TwoEffects. Definition SShrErr := Comb.Shape Share.Shape (Comb.Shape (Error.Shape string) Identity.Shape). Definition PShrErr := Comb.Pos Share.Pos (Comb.Pos (@Error.Pos string) Identity.Pos). - Definition handleShareError (A B : Type) + Definition handleShareError {A B : Type} `{Normalform SShrErr PShrErr A B} (p : Free SShrErr PShrErr A) : (B + string) := run (runError (runEmptySharing (0,0) (nf p))). @@ -159,7 +159,7 @@ Section TwoEffects. Definition SNDErr := Comb.Shape ND.Shape (Comb.Shape (Error.Shape string) Identity.Shape). Definition PNDErr := Comb.Pos ND.Pos (Comb.Pos (@Error.Pos string) Identity.Pos). - Definition handleNDError (A B : Type) + Definition handleNDError {A B : Type} `{Normalform SNDErr PNDErr A B} (p : Free SNDErr PNDErr A) : list B + string := match run (runError (runChoice (nf p))) with @@ -175,7 +175,7 @@ Section TwoEffects. Definition SErrorTrc := Comb.Shape (Error.Shape string) (Comb.Shape Trace.Shape Identity.Shape). Definition PErrorTrc := Comb.Pos (@Error.Pos string) (Comb.Pos Trace.Pos Identity.Pos). - Definition handleErrorTrc (A B : Type) + Definition handleErrorTrc {A B : Type} `{Normalform SErrorTrc PErrorTrc A B} (p : Free SErrorTrc PErrorTrc A) : (B + string) * list string @@ -277,7 +277,7 @@ Section ThreeEffects. (Comb.Pos ND.Pos (Comb.Pos (@Error.Pos string) Identity.Pos)). - Definition handleShareNDError (A B : Type) + Definition handleShareNDError {A B : Type} `{Normalform SShrNDErr PShrNDErr A B} (p : Free SShrNDErr PShrNDErr A) : list B + string @@ -298,7 +298,7 @@ Section ThreeEffects. (Comb.Pos Share.Pos (Comb.Pos Trace.Pos Identity.Pos)). - Definition handleErrorShareTrace (A B : Type) + Definition handleErrorShareTrace {A B : Type} `{Normalform SErrShrTrc PErrShrTrc A B} (p : Free SErrShrTrc PErrShrTrc A) : (B + string) * list string @@ -316,7 +316,7 @@ Section ThreeEffects. (Comb.Pos (@Error.Pos string) (Comb.Pos Trace.Pos Identity.Pos)). - Definition handleNDErrorTrace (A B : Type) + Definition handleNDErrorTrace {A B : Type} `{Normalform SNDErrTrc PNDErrTrc A B} (p : Free SNDErrTrc PNDErrTrc A) : (list B + string) * list string diff --git a/example/Base/NormalizationTests.v b/example/Base/NormalizationTests.v index b4536035..25a715f7 100644 --- a/example/Base/NormalizationTests.v +++ b/example/Base/NormalizationTests.v @@ -2,6 +2,7 @@ From Base Require Import Free. From Base Require Import Free.Handlers. +From Base Require Import Free.Instance.Error. From Base Require Import Free.Instance.Identity. From Base Require Import Free.Instance.Maybe. From Base Require Import Free.Instance.ND. @@ -44,8 +45,9 @@ Definition evalNDMaybe {A : Type} p Definition IdS := Identity.Shape. Definition IdP := Identity.Pos. -(* Infer Shape and Pos for the Maybe Partial instance for convenience- *) +(* Infer Shape and Pos for Partial instances for convenience- *) Arguments Maybe.Partial {_} {_} {_}. +Arguments Error.Partial {_} {_} {_}. (* Effectful lists *) Section SecData. @@ -269,12 +271,17 @@ Example componentEffectND : handleND coinList (List.cons (True_ IdS IdP) (Cons IdS IdP (False_ IdS IdP) (Nil IdS IdP)))]. Proof. constructor. Qed. -(* [true, undefined] --> undefined *) +(* [true, undefined] --> undefined with the Maybe instance of Partial *) Example componentEffectPartial : handleMaybe (partialList Maybe.Partial) = None. Proof. constructor. Qed. -(* [true, false ? undefined] --> undefined *) +(* [true, undefined] --> undefined with the Error instance of Partial *) +Example componentEffectPartialError : handleError (partialList Error.Partial) + = inr "undefined". +Proof. constructor. Qed. + +(* [true, false ? undefined] --> undefined with the ND instance of Partial *) Example componentEffectPartialND : handleNDMaybe (partialCoinList Maybe.Partial) = None. Proof. constructor. Qed. @@ -304,13 +311,22 @@ Proof. constructor. Qed. (* head _ _ Maybe.Partial [true, false ? undefined] --> true *) (* Since non-determinism and Maybe are still handled, the actual - result should be [Some true]. *) + result should be Some [true]. *) Example nonStrictnessNDPartiality : handleNDMaybe (List.head _ _ Maybe.Partial (partialCoinList Maybe.Partial)) = Some [true]. Proof. constructor. Qed. +(* head _ _ Error.Partial [true, false ? undefined] --> true *) +(* Since non-determinism and Error are still handled, the actual + result should be inl [true]. *) +Example nonStrictnessNDPartialityError : handleNDError + (List.head _ _ Error.Partial + (partialCoinList Error.Partial)) + = inl [true]. +Proof. constructor. Qed. + (* Effects at different levels are accumulated. *) (* trace "root effect" [true, trace "component effect" false] From 985535bef06be6bc31d33191823362e773d37802 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 14 Sep 2020 19:15:18 +0200 Subject: [PATCH 051/120] Remove unnecessary whitespace #119 --- base/coq/Free/Handlers.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/base/coq/Free/Handlers.v b/base/coq/Free/Handlers.v index c24630f7..2992e6cf 100644 --- a/base/coq/Free/Handlers.v +++ b/base/coq/Free/Handlers.v @@ -58,7 +58,7 @@ Section OneEffect. := collectVals (run (runChoice (nf p))). (* Trace :+: Identity handler *) - + Definition STrcId := Comb.Shape Trace.Shape Identity.Shape. Definition PTrcId := Comb.Pos Trace.Pos Identity.Pos. @@ -69,7 +69,7 @@ Section OneEffect. collectMessages (run (runTracing (nf p))). (* Share :+: Identity handler *) - + Definition SShrId := Comb.Shape Share.Shape Identity.Shape. Definition PShrId := Comb.Pos Share.Pos Identity.Pos. From bc134ba4e66cd6ab72ef0008cbd8999dc0368852 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Tue, 15 Sep 2020 09:55:45 +0200 Subject: [PATCH 052/120] Adjust tests #150 --- example/Proofs/NormalformProofs.v | 20 +-- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 2 - .../Backend/Coq/Converter/TypeDeclTests.hs | 133 ++++++++++++++++-- 3 files changed, 128 insertions(+), 27 deletions(-) diff --git a/example/Proofs/NormalformProofs.v b/example/Proofs/NormalformProofs.v index 25cb3676..e5159710 100644 --- a/example/Proofs/NormalformProofs.v +++ b/example/Proofs/NormalformProofs.v @@ -36,18 +36,18 @@ Section Data. Notation "'ND'" := (Injectable ND.Shape ND.Pos Shape Pos). Notation Bool_ := (Bool Shape Pos). - Notation True_ := (True_ Shape Pos). - Notation False_ := (False_ Shape Pos). + Notation True' := (True_ Shape Pos). + Notation False' := (False_ Shape Pos). Notation "x ? y" := (Choice Shape Pos x y) (at level 50). (* true : ([] ? [true ? false]) *) Definition ndList `{ND} : Free Shape Pos (MyList Shape Pos Bool_) := MyCons Shape Pos - True_ + True' ( MyNil Shape Pos ? MyCons Shape Pos - (True_ ? False_) + (True' ? False') (MyNil Shape Pos)). (* (foo (bar (foo baz))) ? (foo baz) *) @@ -61,10 +61,10 @@ Section Data. (* branch (true ? false) (leaf : ([] ? [leaf])) *) Definition ndTree `{ND} : Free Shape Pos (Tree Shape Pos Bool_) := Branch Shape Pos - (True_ ? False_) + (True' ? False') (Cons Shape Pos (Leaf Shape Pos) - ( Nil Shape Pos + (Nil Shape Pos ? Cons Shape Pos (Leaf Shape Pos) (Nil Shape Pos))). @@ -72,12 +72,12 @@ Section Data. (* (true -> (true ? false)) : ([] ? [(true ? false) -> false]) *) Definition ndMap `{ND} : Free Shape Pos (Map Shape Pos Bool_ Bool_) := Entry0 Shape Pos - True_ - (True_ ? False_) + True' + (True' ? False') ( Empty Shape Pos ? Entry0 Shape Pos - (True_ ? False_) - False_ + (True' ? False') + False' (Empty Shape Pos)). End Data. diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 3fea7f61..1c292067 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -32,8 +32,6 @@ import FreeC.Environment import FreeC.Environment.Entry import FreeC.Environment.Fresh import FreeC.Environment.LookupOrFail -import FreeC.Environment.Fresh - ( freshArgPrefix, freshCoqIdent ) import FreeC.Environment.Renamer ( renameAndDefineTypeVar ) import FreeC.IR.DependencyGraph import FreeC.IR.SrcSpan ( SrcSpan(NoSrcSpan) ) diff --git a/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs b/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs index 1790569c..778f2b3c 100644 --- a/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs +++ b/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs @@ -69,9 +69,12 @@ testConvertTypeDecl it "expands type synonyms in mutually recursive data type declarations" $ shouldSucceedWith $ do - "List" <- defineTestTypeCon "List" 1 [] + "List" <- defineTestTypeCon "List" 1 ["Nil", "Cons"] + ("nil", "Nil") <- defineTestCon "Nil" 0 "forall a. List a" + ("cons", "Cons") + <- defineTestCon "Cons" 2 "forall a . a -> List a -> List a" "Forest" <- defineTestTypeSyn "Forest" ["a"] "List (Tree a)" - "Tree" <- defineTestTypeCon "Tree" 1 [] + "Tree" <- defineTestTypeCon "Tree" 1 ["Leaf", "Branch"] ("leaf", "Leaf") <- defineTestCon "Leaf" 1 "forall a. a -> Tree a" ("branch", "Branch") <- defineTestCon "Branch" 1 "forall a. Forest a -> Tree a" @@ -101,6 +104,31 @@ testConvertTypeDecl ++ "Notation \"'@Branch' Shape Pos a x_0\" :=" ++ " (@pure Shape Pos (Tree Shape Pos a) (@branch Shape Pos a x_0))" ++ " ( only parsing, at level 10, Shape, Pos, a, x_0 at level 9 ). " + ++ " (* Normalform instance for Tree *) " + ++ "Fixpoint nf'Tree__0 {Shape : Type} {Pos : Shape -> Type} " + ++ "{a_0 b_0 : Type} `{Normalform Shape Pos a_0 b_0} " + ++ "(x_0 : Tree Shape Pos a_0) " + ++ ": Free Shape Pos (Tree Identity.Shape Identity.Pos b_0) " + ++ ":= let fix nf'ListTree__0 {a_1 b_1 : Type} " + ++ "`{Normalform Shape Pos a_1 b_1} " + ++ "(x_4 : List Shape Pos (Tree Shape Pos a_1)) " + ++ ": Free Shape Pos (List Identity.Shape Identity.Pos " + ++ "(Tree Identity.Shape Identity.Pos b_1)) := match x_4 with " + ++ "| nil => pure nil " + ++ "| cons fx_2 fx_3 => fx_2 >>= (fun x_7 => " + ++ "nf'Tree__0 x_7 >>= (fun nx_2 => " + ++ "fx_3 >>= (fun x_8 => nf'ListTree__0 x_8 >>= (fun nx_3 => " + ++ "pure (cons (pure nx_2) (pure nx_3)))))) " + ++ "end " + ++ "in match x_0 with " + ++ "| leaf fx_0 => nf fx_0 >>= (fun nx_0 => pure (leaf (pure nx_0))) " + ++ "| branch fx_1 => fx_1 >>= (fun x_3 => " + ++ "nf'ListTree__0 x_3 >>= (fun nx_1 => pure (branch (pure nx_1)))) " + ++ "end. " + ++ "Instance NormalformTree__0 {Shape : Type} {Pos : Shape -> Type} " + ++ "{a_0 b_0 : Type} `{Normalform Shape Pos a_0 b_0} " + ++ ": Normalform Shape Pos (Tree Shape Pos a_0) " + ++ "(Tree Identity.Shape Identity.Pos b_0) := { nf' := nf'Tree__0 }. " ++ "Definition Forest (Shape : Type) (Pos : Shape -> Type)" ++ " (a : Type)" ++ " : Type" @@ -128,6 +156,17 @@ testConvertTypeDecl ++ "Notation \"'@Foo0' Shape Pos x_0 x_1\" :=" ++ " (@pure Shape Pos (Foo Shape Pos) (@foo Shape Pos x_0 x_1))" ++ " ( only parsing, at level 10, Shape, Pos, x_0, x_1 at level 9 ). " + ++ " (* Normalform instance for Foo *) " + ++ "Fixpoint nf'Foo_0 {Shape : Type} {Pos : Shape -> Type} " + ++ "(x_0 : Foo Shape Pos) " + ++ ": Free Shape Pos (Foo Identity.Shape Identity.Pos) " + ++ ":= let 'foo fx_0 fx_1 := x_0 in fx_0 >>= (fun x_1 => " + ++ "nf'Foo_0 x_1 >>= (fun nx_0 => " + ++ "fx_1 >>= (fun x_2 => nf'Foo_0 x_2 >>= (fun nx_1 => " + ++ "pure (foo (pure nx_0) (pure nx_1)))))). " + ++ "Instance NormalformFoo_0 {Shape : Type} {Pos : Shape -> Type} " + ++ ": Normalform Shape Pos (Foo Shape Pos) " + ++ "(Foo Identity.Shape Identity.Pos) := { nf' := nf'Foo_0 }. " ++ "Definition Baz (Shape : Type) (Pos : Shape -> Type)" ++ " : Type" ++ " := Foo Shape Pos. " @@ -177,6 +216,17 @@ testConvertDataDecls ++ "Notation \"'@Baz' Shape Pos\" :=" ++ " (@pure Shape Pos (Foo Shape Pos) (@baz Shape Pos))" ++ " ( only parsing, at level 10, Shape, Pos at level 9 ). " + ++ "(* Normalform instance for Foo *) " + ++ "Fixpoint nf'Foo_0 {Shape : Type} {Pos : Shape -> Type} " + ++ "(x_0 : Foo Shape Pos) " + ++ ": Free Shape Pos (Foo Identity.Shape Identity.Pos) " + ++ ":= match x_0 with " + ++ "| bar => pure bar " + ++ "| baz => pure baz " + ++ "end. " + ++ "Instance NormalformFoo_0 {Shape : Type} {Pos : Shape -> Type} " + ++ ": Normalform Shape Pos (Foo Shape Pos) " + ++ "(Foo Identity.Shape Identity.Pos) := { nf' := nf'Foo_0 }. " it "translates polymorphic data types correctly" $ shouldSucceedWith $ do "Foo" <- defineTestTypeCon "Foo" 2 ["Bar", "Baz"] ("bar", "Bar") <- defineTestCon "Bar" 1 "forall a b. a -> Foo a b" @@ -204,6 +254,23 @@ testConvertDataDecls ++ "Notation \"'@Baz' Shape Pos a b x_0\" :=" ++ " (@pure Shape Pos (Foo Shape Pos a b) (@baz Shape Pos a b x_0))" ++ " ( only parsing, at level 10, Shape, Pos, a, b, x_0 at level 9 ). " + ++ "(* Normalform instance for Foo *) " + ++ "Fixpoint nf'Foo___0 {Shape : Type} {Pos : Shape -> Type} " + ++ "{a_0 a_1 b_0 b_1 : Type} `{Normalform Shape Pos a_0 b_0} " + ++ "`{Normalform Shape Pos a_1 b_1} (x_0 : Foo Shape Pos a_0 a_1) " + ++ ": Free Shape Pos (Foo Identity.Shape Identity.Pos b_0 b_1) " + ++ ":= match x_0 with " + ++ "| bar fx_0 => nf fx_0 >>= " + ++ "(fun nx_0 => pure (bar (pure nx_0))) " + ++ "| baz fx_1 => " + ++ "nf fx_1 >>= (fun nx_1 => pure (baz (pure nx_1))) " + ++ "end. " + ++ "Instance NormalformFoo___0 {Shape : Type} {Pos : Shape -> Type} " + ++ "{a_0 a_1 b_0 b_1 : Type} `{Normalform Shape Pos a_0 b_0} " + ++ "`{Normalform Shape Pos a_1 b_1} " + ++ ": Normalform Shape Pos (Foo Shape Pos a_0 a_1) " + ++ "(Foo Identity.Shape Identity.Pos b_0 b_1) " + ++ ":= { nf' := nf'Foo___0 }." it "renames constructors with same name as their data type" $ shouldSucceedWith $ do @@ -222,6 +289,15 @@ testConvertDataDecls ++ "Notation \"'@Foo0' Shape Pos\" :=" ++ " (@pure Shape Pos (Foo Shape Pos) (@foo Shape Pos))" ++ " ( only parsing, at level 10, Shape, Pos at level 9 ). " + ++ "(* Normalform instance for Foo *) " + ++ "Fixpoint nf'Foo_0 {Shape : Type} {Pos : Shape -> Type} " + ++ "(x_0 : Foo Shape Pos) " + ++ ": Free Shape Pos (Foo Identity.Shape Identity.Pos) " + ++ ":= let 'foo := x_0 in pure foo. " + ++ "Instance NormalformFoo_0 {Shape : Type} {Pos : Shape -> Type} " + ++ ": Normalform Shape Pos (Foo Shape Pos) " + ++ "(Foo Identity.Shape Identity.Pos) " + ++ ":= { nf' := nf'Foo_0 }." it "renames type variables with same name as generated constructors" $ shouldSucceedWith $ do @@ -241,6 +317,18 @@ testConvertDataDecls ++ "Notation \"'@A' Shape Pos a0 x_0\" :=" ++ " (@pure Shape Pos (Foo Shape Pos a0) (@a Shape Pos a0 x_0))" ++ " ( only parsing, at level 10, Shape, Pos, a0, x_0 at level 9 ). " + ++ "(* Normalform instance for Foo *) " + ++ "Fixpoint nf'Foo__0 {Shape : Type} {Pos : Shape -> Type} " + ++ "{a_0 b_0 : Type} `{Normalform Shape Pos a_0 b_0} " + ++ "(x_0 : Foo Shape Pos a_0) " + ++ ": Free Shape Pos (Foo Identity.Shape Identity.Pos b_0) " + ++ ":= let 'a fx_0 := x_0 " + ++ "in nf fx_0 >>= (fun nx_0 => pure (a (pure nx_0))). " + ++ "Instance NormalformFoo__0 {Shape : Type} {Pos : Shape -> Type} " + ++ "{a_0 b_0 : Type} `{Normalform Shape Pos a_0 b_0} " + ++ ": Normalform Shape Pos (Foo Shape Pos a_0) " + ++ "(Foo Identity.Shape Identity.Pos b_0) " + ++ ":= { nf' := nf'Foo__0 }." it "translates mutually recursive data types correctly" $ shouldSucceedWith $ do @@ -273,6 +361,23 @@ testConvertDataDecls ++ "Notation \"'@Bar0' Shape Pos x_0\" :=" ++ " (@pure Shape Pos (Bar Shape Pos) (@bar Shape Pos x_0))" ++ " ( only parsing, at level 10, Shape, Pos, x_0 at level 9 ). " + ++ "(* Normalform instances for Foo, Bar *) " + ++ "Fixpoint nf'Foo_0 {Shape : Type} {Pos : Shape -> Type} " + ++ "(x_0 : Foo Shape Pos) " + ++ ": Free Shape Pos (Foo Identity.Shape Identity.Pos) " + ++ ":= let 'foo fx_0 := x_0 in fx_0 >>= (fun x_1 => " + ++ "nf'Bar_0 x_1 >>= (fun nx_0 => pure (foo (pure nx_0)))) " + ++ "with nf'Bar_0 {Shape : Type} {Pos : Shape -> Type} " + ++ "(x_0 : Bar Shape Pos) " + ++ ": Free Shape Pos (Bar Identity.Shape Identity.Pos) " + ++ ":= let 'bar fx_0 := x_0 in fx_0 >>= (fun x_1 => " + ++ "nf'Foo_0 x_1 >>= (fun nx_0 => pure (bar (pure nx_0)))). " + ++ "Instance NormalformFoo_0 {Shape : Type} {Pos : Shape -> Type} " + ++ ": Normalform Shape Pos (Foo Shape Pos) " + ++ "(Foo Identity.Shape Identity.Pos) := { nf' := nf'Foo_0 }. " + ++ "Instance NormalformBar_0 {Shape : Type} {Pos : Shape -> Type} " + ++ ": Normalform Shape Pos (Bar Shape Pos) " + ++ "(Bar Identity.Shape Identity.Pos) := { nf' := nf'Bar_0 }." context "Generation of qualified smart constructor notations" $ do it "produces qualified notations for a single type correctly" $ shouldSucceedWith @@ -326,26 +431,24 @@ testConvertDataDecls it "produces notations for two mutually recursive types correctly" $ shouldSucceedWith $ do - _ <- defineTestTypeCon "A.Foo1" 1 ["A.Bar1"] - _ <- defineTestTypeCon "A.Foo2" 1 ["A.Bar2"] + _ <- defineTestTypeCon "A.Foo1" 0 ["A.Bar1"] + _ <- defineTestTypeCon "A.Foo2" 0 ["A.Bar2"] _ <- defineTestCon "A.Bar1" 1 "A.Foo2 -> A.Foo1" _ <- defineTestCon "A.Bar2" 1 "A.Foo1 -> A.Foo2" shouldProduceQualifiedNotations (Recursive - ["data A.Foo1 a = A.Bar1 A.Foo2", "data A.Foo2 a = A.Bar2 A.Foo1"]) + ["data A.Foo1 = A.Bar1 A.Foo2", "data A.Foo2 = A.Bar2 A.Foo1"]) $ "(* Qualified smart constructors for Foo1 *) " ++ "Notation \"'A.Bar1' Shape Pos x_0\" := " - ++ "(@pure Shape Pos _ (@bar1 Shape Pos _ x_0)) " + ++ "(@pure Shape Pos (Foo1 Shape Pos) (@bar1 Shape Pos x_0)) " ++ "( at level 10, Shape, Pos, x_0 at level 9 ). " - ++ "Notation \"'@A.Bar1' Shape Pos a x_0\" := " - ++ "(@pure Shape Pos (Foo1 Shape Pos) (@bar1 Shape Pos a x_0)) " - ++ "( only parsing, at level 10, Shape, Pos, a, x_0 at level 9 ). " + ++ "Notation \"'@A.Bar1' Shape Pos x_0\" := " + ++ "(@pure Shape Pos (Foo1 Shape Pos) (@bar1 Shape Pos x_0)) " + ++ "( only parsing, at level 10, Shape, Pos, x_0 at level 9 ). " ++ "(* Qualified smart constructors for Foo2 *) " ++ "Notation \"'A.Bar2' Shape Pos x_0\" := " - ++ "(@pure Shape Pos _ (@bar2 Shape Pos _ x_0)) " + ++ "(@pure Shape Pos (Foo2 Shape Pos) (@bar2 Shape Pos x_0)) " ++ "( at level 10, Shape, Pos, x_0 at level 9 ). " - ++ "Notation \"'@A.Bar2' Shape Pos a x_0\" := " - ++ "(@pure Shape Pos (Foo2 Shape Pos) (@bar2 Shape Pos a x_0)) " - ++ "( only parsing, at level 10, Shape, Pos, a, x_0 at level 9 )." - - + ++ "Notation \"'@A.Bar2' Shape Pos x_0\" := " + ++ "(@pure Shape Pos (Foo2 Shape Pos) (@bar2 Shape Pos x_0)) " + ++ "( only parsing, at level 10, Shape, Pos, x_0 at level 9 )." From 258155e931f6434faf2351499cffbe4e595f137c Mon Sep 17 00:00:00 2001 From: Niels Bunkenburg <30875649+nbun@users.noreply.github.com> Date: Tue, 15 Sep 2020 12:45:20 +0200 Subject: [PATCH 053/120] Fix typo --- example/Base/NormalizationTests.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/example/Base/NormalizationTests.v b/example/Base/NormalizationTests.v index 25a715f7..dd7dfdd7 100644 --- a/example/Base/NormalizationTests.v +++ b/example/Base/NormalizationTests.v @@ -45,7 +45,7 @@ Definition evalNDMaybe {A : Type} p Definition IdS := Identity.Shape. Definition IdP := Identity.Pos. -(* Infer Shape and Pos for Partial instances for convenience- *) +(* Infer Shape and Pos for Partial instances for convenience. *) Arguments Maybe.Partial {_} {_} {_}. Arguments Error.Partial {_} {_} {_}. From 9760c86c33c74466f6954e4bd8f1c6eaa7d478f4 Mon Sep 17 00:00:00 2001 From: Niels Bunkenburg <30875649+nbun@users.noreply.github.com> Date: Tue, 15 Sep 2020 12:45:48 +0200 Subject: [PATCH 054/120] Fix typo --- example/Proofs/ConsUnconsProofs.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/example/Proofs/ConsUnconsProofs.v b/example/Proofs/ConsUnconsProofs.v index 045c12bf..e5206a20 100644 --- a/example/Proofs/ConsUnconsProofs.v +++ b/example/Proofs/ConsUnconsProofs.v @@ -41,7 +41,7 @@ Section ErrorMessages. an [error] with a specific message. *) Definition EmptyListError {A : Type} := @error _ _ (Error.Partial _ _) A "unconsE: empty list"%string. - (* If we weren't looking for an actual [error] but for an [undefined] in haskell + (* If we weren't looking for an actual [error] but for an [undefined] in Haskell we could use the following definition. *) Definition Undefined {A : Type} := @undefined _ _ (Error.Partial _ _) A. From 02a3b00d8f66b42bd2b84ecc92b6974c37efba96 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Tue, 15 Sep 2020 18:39:17 +0200 Subject: [PATCH 055/120] Format code with Floskell #150 --- src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 4723d708..2ddfa2d2 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -31,7 +31,8 @@ import FreeC.Backend.Coq.Converter.Type import qualified FreeC.Backend.Coq.Syntax as Coq import FreeC.Environment import FreeC.Environment.Entry -import FreeC.Environment.Fresh ( freshArgPrefix, freshCoqIdent, freshCoqQualid, freshHaskellIdent ) +import FreeC.Environment.Fresh + ( freshArgPrefix, freshCoqIdent, freshCoqQualid, freshHaskellIdent ) import FreeC.Environment.LookupOrFail import FreeC.Environment.Renamer ( renameAndDefineTypeVar ) import FreeC.IR.DependencyGraph @@ -360,7 +361,7 @@ convertDataDecl (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do fArgTypes <- mapM convertType argTypes (argIdents, argBinders) <- mapAndUnzipM convertAnonymousArg (map Just argTypes) - let + let -- We need an induction hypothesis for every argument that has the same -- type as the constructor but lifted into the free monad. addHypotheses' :: [(Coq.Term, Coq.Qualid)] -> Coq.Term -> Coq.Term From deb41b356b5bc2be23f67525c1baf2d0ee0b8289 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Tue, 15 Sep 2020 19:45:28 +0200 Subject: [PATCH 056/120] Generate ShareableArgs instances #150 #151 --- src/lib/FreeC/Backend/Coq/Base.hs | 16 ++- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 103 ++++++++++++++---- 2 files changed, 98 insertions(+), 21 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Base.hs b/src/lib/FreeC/Backend/Coq/Base.hs index 3ce9d464..1d32a306 100644 --- a/src/lib/FreeC/Backend/Coq/Base.hs +++ b/src/lib/FreeC/Backend/Coq/Base.hs @@ -30,6 +30,8 @@ module FreeC.Backend.Coq.Base , strategyArg , shareableArgs , shareableArgsBinder + , normalform + , normalformBinder , implicitArg , share -- * Effect Selection @@ -177,7 +179,7 @@ strategyBinder :: Coq.Binder strategyBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit strategyArg $ Coq.app (Coq.Qualid strategy) [Coq.Qualid shape, Coq.Qualid pos] --- | The Coq binder for the @ShareableArgs@ type class. +-- | The Coq identifier for the @ShareableArgs@ type class. shareableArgs :: Coq.Qualid shareableArgs = Coq.bare "ShareableArgs" @@ -188,6 +190,17 @@ shareableArgsBinder typeArg = Coq.Generalized Coq.Implicit $ Coq.app (Coq.Qualid shareableArgs) $ map Coq.Qualid [shape, pos, typeArg] +-- | The Coq identifier for the @Normalform@ type class. +normalform :: Coq.Qualid +normalform = Coq.bare "Normalform" + +-- | The Coq binder for the @Normalform@ type class with the source and target +-- type variable with the given names. +normalformBinder :: Coq.Qualid -> Coq.Qualid -> Coq.Binder +normalformBinder sourceType targetType = Coq.Generalized Coq.Implicit + $ Coq.app (Coq.Qualid normalform) + $ map Coq.Qualid [shape, pos, sourceType, targetType] + -- | The Coq identifier for an implicit argument. implicitArg :: Coq.Term implicitArg = Coq.Underscore @@ -269,6 +282,7 @@ reservedIdents , strategy , strategyArg , shareableArgs + , normalform , share ] ++ map fst freeArgs diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 2ddfa2d2..1815991b 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -505,8 +505,12 @@ generateTypeclassInstances dataDecls = do let recTypeList = map (filter (\t -> not (t `elem` declTypes || IR.isTypeVar t))) reducedTypes -- Construct Normalform instances. - buildInstances recTypeList normalformFuncName normalformClassName - nfBindersAndReturnType buildNormalformValue + nfInstances <- buildInstances recTypeList normalformFuncName + normalformClassName nfBindersAndReturnType buildNormalformValue + -- Construct ShareableArgs instances. + shareableArgsInstances <- buildInstances recTypeList shareableArgsFuncName + shareableArgsClassName shareArgsBindersAndReturnType buildShareArgsValue + return (nfInstances ++ shareableArgsInstances) where -- The (mutually recursive) data types for which we are defining -- instances, converted to types. @@ -695,19 +699,22 @@ generateTypeclassInstances dataDecls = do normalformFuncName :: String normalformFuncName = "nf'" + -- | The function nf. + normalformFunc :: Coq.Term + normalformFunc = Coq.Qualid (Coq.bare "nf") + -- | The binders and return types for the Normalform class function and instance. nfBindersAndReturnType :: - -- The type for which we are defining an instance. + -- The type @t@ for which we are defining an instance. IR.Type -> Coq.Qualid -> Converter ( [Coq.Binder] -- Type variable binders and Normalform constraints. , Coq.Binder -- Binder for the argument of type @t@. - , Coq.Term -- Return type of nf'. - , Coq.Term - ) -- Return type of the Normalform instance. - + , Coq.Term -- Return type of @nf'@. + , Coq.Term -- Return type of the Normalform instance. + ) nfBindersAndReturnType t varName = do -- For each type variable in the type, generate two type variables. -- One represents the type's variable itself, the other the result @@ -719,11 +726,11 @@ generateTypeclassInstances dataDecls = do (targetType, targetVars) <- toCoqType "b" idShapeAndPos t -- For each type variable ai, build a constraint -- `{Normalform Shape Pos ai bi}. - let constraints = map (buildConstraint normalformClassName) - (zipWith (\v1 v2 -> [v1, v2]) sourceVars targetVars) - let varBinders + let constraints = map (uncurry Coq.Base.normalformBinder) + (zip sourceVars targetVars) + let varBinder = [typeVarBinder (sourceVars ++ targetVars) | not (null sourceVars)] - let binders = varBinders ++ constraints + let binders = varBinder ++ constraints -- Create an explicit argument binder for the value to be normalized. let topLevelVarBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit varName sourceType @@ -737,7 +744,10 @@ generateTypeclassInstances dataDecls = do buildNormalformValue :: -- A map to associate types with the appropriate functions to call. - TypeMap -> Coq.Qualid -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term + TypeMap + -> Coq.Qualid + -> [(IR.Type, Coq.Qualid)] + -> Converter Coq.Term buildNormalformValue nameMap consName = buildNormalformValue' [] where -- | Like 'buildNormalformValue', but with an additional parameter to accumulate @@ -775,9 +785,69 @@ generateTypeclassInstances dataDecls = do nx <- freshCoqQualid ("n" ++ freshArgPrefix) rhs <- buildNormalformValue' (nx : boundVars) consVars let c = Coq.fun [nx] [Nothing] rhs + return $ applyBind (Coq.app normalformFunc [Coq.Qualid varName]) c + + ------------------------------------------------------------------------------- + -- Functions to produce ShareableArgs instances -- + ------------------------------------------------------------------------------- + -- | The name of the Normalform class. + shareableArgsClassName :: String + shareableArgsClassName = "ShareableArgs" + + -- | The name of the Normalform class function. + shareableArgsFuncName :: String + shareableArgsFuncName = "shareArgs" + + -- | The name of the cbneed operator. + cbneedFunc :: Coq.Term + cbneedFunc = Coq.Qualid (Coq.bare "cbneed") + + -- | The binders and return types for the ShareableArgs class function and instance. + shareArgsBindersAndReturnType + :: IR.Type + -> Coq.Qualid + -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) + shareArgsBindersAndReturnType t varName = do + (coqType, vars) <- toCoqType "a" shapeAndPos t + let constraints + = Coq.Base.injectableBinder : map Coq.Base.shareableArgsBinder vars + let varBinder = [typeVarBinder vars | not (null vars)] + let binders = varBinder ++ constraints + let topLevelVarBinder + = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit varName coqType + let instanceRetType = Coq.app (Coq.Qualid Coq.Base.shareableArgs) + (shapeAndPos ++ [coqType]) + let funcRetType = applyFree coqType + return (binders, topLevelVarBinder, funcRetType, instanceRetType) + + -- | Shares all arguments of the given constructor and reconstructs the + -- value with the shared components. + buildShareArgsValue + :: TypeMap -> Coq.Qualid -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term + buildShareArgsValue nameMap consName = buildShareArgsValue' [] + where + buildShareArgsValue' + :: [Coq.Qualid] -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term + buildShareArgsValue' vals [] + = (generatePure (Coq.app (Coq.Qualid consName) + (map Coq.Qualid (reverse vals)))) + buildShareArgsValue' vals ((t, varName) : consVars) = do + sx <- freshCoqQualid ("s" ++ freshArgPrefix) + rhs <- buildShareArgsValue' (sx : vals) consVars + case Map.lookup t nameMap of + Just funcName -> do return $ applyBind - (Coq.app (Coq.Qualid (Coq.bare "nf")) [Coq.Qualid varName]) c + (Coq.app cbneedFunc + (shapeAndPos ++ [Coq.Qualid funcName, Coq.Qualid varName])) + (Coq.fun [sx] [Nothing] rhs) + Nothing -> do + return + $ applyBind (Coq.app cbneedFunc + (shapeAndPos + ++ [ Coq.Qualid (Coq.bare shareableArgsFuncName) + , Coq.Qualid varName + ])) (Coq.fun [sx] [Nothing] rhs) ------------------------------------------------------------------------------- -- Helper functions -- @@ -911,13 +981,6 @@ generateTypeclassInstances dataDecls = do typeVarBinder typeVars = Coq.typedBinder Coq.Ungeneralizable Coq.Implicit typeVars Coq.sortType - -- | Constructs a type class constraint. - -- > buildConstraint name [a1 ... an] = `{name Shape Pos a1 ... an}. - buildConstraint :: String -> [Coq.Qualid] -> Coq.Binder - buildConstraint className args = Coq.Generalized Coq.Implicit - (Coq.app (Coq.Qualid (Coq.bare className)) - (shapeAndPos ++ map Coq.Qualid args)) - -- | Shortcut for the application of >>=. applyBind :: Coq.Term -> Coq.Term -> Coq.Term applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [mx, f] From 7cf7f1b83c2692e5fbc19d7652b2341df133f453 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Tue, 15 Sep 2020 20:06:29 +0200 Subject: [PATCH 057/120] Adjust tests #150 #151 --- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 5 +- .../Backend/Coq/Converter/TypeDeclTests.hs | 140 +++++++++++++++++- 2 files changed, 137 insertions(+), 8 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 1815991b..6e3739a4 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -744,10 +744,7 @@ generateTypeclassInstances dataDecls = do buildNormalformValue :: -- A map to associate types with the appropriate functions to call. - TypeMap - -> Coq.Qualid - -> [(IR.Type, Coq.Qualid)] - -> Converter Coq.Term + TypeMap -> Coq.Qualid -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term buildNormalformValue nameMap consName = buildNormalformValue' [] where -- | Like 'buildNormalformValue', but with an additional parameter to accumulate diff --git a/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs b/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs index 64416276..3943980a 100644 --- a/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs +++ b/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs @@ -138,6 +138,36 @@ testConvertTypeDecl ++ "{a b : Type} `{Normalform Shape Pos a b} " ++ ": Normalform Shape Pos (Tree Shape Pos a) " ++ "(Tree Identity.Shape Identity.Pos b) := { nf' := nf'Tree_ }. " + ++ "(* ShareableArgs instance for Tree *) " + ++ "Fixpoint shareArgsTree_ {Shape : Type} {Pos : Shape -> Type} " + ++ "{a : Type} `{Injectable Share.Shape Share.Pos Shape Pos} " + ++ "`{ShareableArgs Shape Pos a} (x : Tree Shape Pos a) " + ++ ": Free Shape Pos (Tree Shape Pos a) " + ++ ":= let fix shareArgsListTree_ {a0 : Type} " + ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " + ++ "`{ShareableArgs Shape Pos a0} " + ++ "(x0 : List Shape Pos (Tree Shape Pos a0)) " + ++ ": Free Shape Pos (List Shape Pos (Tree Shape Pos a0)) " + ++ ":= match x0 with " + ++ "| nil => pure nil " + ++ "| cons fx1 fx2 => " + ++ "cbneed Shape Pos shareArgsTree_ fx1 >>= (fun sx1 => " + ++ "cbneed Shape Pos shareArgsListTree_ fx2 >>= (fun sx2 => " + ++ "pure (cons sx1 sx2))) " + ++ "end " + ++ "in match x with " + ++ "| leaf fx => cbneed Shape Pos shareArgs fx >>= (fun sx => " + ++ "pure (leaf sx)) " + ++ "| branch fx0 => " + ++ "cbneed Shape Pos shareArgsListTree_ fx0 >>= (fun sx0 => " + ++ "pure (branch sx0)) " + ++ "end. " + ++ "Instance ShareableArgsTree_ {Shape : Type} " + ++ "{Pos : Shape -> Type} {a : Type} " + ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " + ++ "`{ShareableArgs Shape Pos a} " + ++ ": ShareableArgs Shape Pos (Tree Shape Pos a) " + ++ ":= { shareArgs := shareArgsTree_ }. " ++ "Definition Forest (Shape : Type) (Pos : Shape -> Type)" ++ " (a : Type)" ++ " : Type" @@ -186,6 +216,17 @@ testConvertTypeDecl ++ "Instance NormalformFoo {Shape : Type} {Pos : Shape -> Type} " ++ ": Normalform Shape Pos (Foo Shape Pos) " ++ "(Foo Identity.Shape Identity.Pos) := { nf' := nf'Foo }. " + ++ "(* ShareableArgs instance for Foo *) " + ++ "Fixpoint shareArgsFoo {Shape : Type} {Pos : Shape -> Type} " + ++ "`{Injectable Share.Shape Share.Pos Shape Pos} (x : Foo Shape Pos) " + ++ ": Free Shape Pos (Foo Shape Pos) := let 'foo fx fx0 := x " + ++ "in cbneed Shape Pos shareArgsFoo fx >>= (fun sx => " + ++ "cbneed Shape Pos shareArgsFoo fx0 >>= (fun sx0 => " + ++ "pure (foo sx sx0))). " + ++ "Instance ShareableArgsFoo {Shape : Type} {Pos : Shape -> Type} " + ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " + ++ ": ShareableArgs Shape Pos (Foo Shape Pos) " + ++ ":= { shareArgs := shareArgsFoo }. " ++ "Definition Baz (Shape : Type) (Pos : Shape -> Type)" ++ " : Type" ++ " := Foo Shape Pos. " @@ -253,6 +294,19 @@ testConvertDataDecls ++ "Instance NormalformFoo {Shape : Type} {Pos : Shape -> Type} " ++ ": Normalform Shape Pos (Foo Shape Pos) " ++ "(Foo Identity.Shape Identity.Pos) := { nf' := nf'Foo }. " + ++ "(* ShareableArgs instance for Foo *) " + ++ "Fixpoint shareArgsFoo {Shape : Type} {Pos : Shape -> Type} " + ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " + ++ "(x : Foo Shape Pos) : Free Shape Pos (Foo Shape Pos) " + ++ ":= match x with " + ++ "| bar => pure bar " + ++ "| baz => pure baz " + ++ "end. " + ++ "Instance ShareableArgsFoo {Shape : Type} " + ++ "{Pos : Shape -> Type} " + ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " + ++ ": ShareableArgs Shape Pos (Foo Shape Pos) " + ++ ":= { shareArgs := shareArgsFoo }. " it "translates polymorphic data types correctly" $ shouldSucceedWith $ do "Foo" <- defineTestTypeCon "Foo" 2 ["Bar", "Baz"] ("bar", "Bar") <- defineTestCon "Bar" 1 "forall a b. a -> Foo a b" @@ -304,7 +358,25 @@ testConvertDataDecls ++ "`{Normalform Shape Pos a0 b0} " ++ ": Normalform Shape Pos (Foo Shape Pos a a0) " ++ "(Foo Identity.Shape Identity.Pos b b0) " - ++ ":= { nf' := nf'Foo__ }." + ++ ":= { nf' := nf'Foo__ }. " + ++ "(* ShareableArgs instance for Foo *) " + ++ "Fixpoint shareArgsFoo__ {Shape : Type} " + ++ "{Pos : Shape -> Type} {a a0 : Type} " + ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " + ++ "`{ShareableArgs Shape Pos a} `{ShareableArgs Shape Pos a0} " + ++ "(x : Foo Shape Pos a a0) : Free Shape Pos (Foo Shape Pos a a0) " + ++ ":= match x with " + ++ "| bar fx => cbneed Shape Pos shareArgs fx >>= (fun sx => " + ++ "pure (bar sx)) " + ++ "| baz fx0 => cbneed Shape Pos shareArgs fx0 >>= (fun sx0 => " + ++ "pure (baz sx0)) " + ++ "end. " + ++ "Instance ShareableArgsFoo__ {Shape : Type} " + ++ "{Pos : Shape -> Type} {a a0 : Type} " + ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " + ++ "`{ShareableArgs Shape Pos a} `{ShareableArgs Shape Pos a0} " + ++ ": ShareableArgs Shape Pos (Foo Shape Pos a a0) " + ++ ":= { shareArgs := shareArgsFoo__ }. " it "renames constructors with same name as their data type" $ shouldSucceedWith $ do @@ -337,7 +409,17 @@ testConvertDataDecls ++ "Instance NormalformFoo {Shape : Type} {Pos : Shape -> Type} " ++ ": Normalform Shape Pos (Foo Shape Pos) " ++ "(Foo Identity.Shape Identity.Pos) " - ++ ":= { nf' := nf'Foo }." + ++ ":= { nf' := nf'Foo }. " + ++ "(* ShareableArgs instance for Foo *) " + ++ "Fixpoint shareArgsFoo {Shape : Type} {Pos : Shape -> Type} " + ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " + ++ "(x : Foo Shape Pos) : Free Shape Pos (Foo Shape Pos) " + ++ ":= let 'foo := x in pure foo. " + ++ "Instance ShareableArgsFoo {Shape : Type} " + ++ "{Pos : Shape -> Type} " + ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " + ++ ": ShareableArgs Shape Pos (Foo Shape Pos) " + ++ ":= { shareArgs := shareArgsFoo }. " it "renames type variables with same name as generated constructors" $ shouldSucceedWith $ do @@ -375,7 +457,19 @@ testConvertDataDecls ++ "{a0 b : Type} `{Normalform Shape Pos a0 b} " ++ ": Normalform Shape Pos (Foo Shape Pos a0) " ++ "(Foo Identity.Shape Identity.Pos b) " - ++ ":= { nf' := nf'Foo_ }." + ++ ":= { nf' := nf'Foo_ }. " + ++ "(* ShareableArgs instance for Foo *) " + ++ "Fixpoint shareArgsFoo_ {Shape : Type} {Pos : Shape -> Type} " + ++ "{a0 : Type} `{Injectable Share.Shape Share.Pos Shape Pos} " + ++ "`{ShareableArgs Shape Pos a0} (x : Foo Shape Pos a0) " + ++ ": Free Shape Pos (Foo Shape Pos a0) := let 'a fx := x in " + ++ "cbneed Shape Pos shareArgs fx >>= (fun sx => pure (a sx)). " + ++ "Instance ShareableArgsFoo_ {Shape : Type} " + ++ "{Pos : Shape -> Type} {a0 : Type} " + ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " + ++ "`{ShareableArgs Shape Pos a0} " + ++ ": ShareableArgs Shape Pos (Foo Shape Pos a0) " + ++ ":= { shareArgs := shareArgsFoo_ }." it "translates mutually recursive data types correctly" $ shouldSucceedWith $ do @@ -436,7 +530,30 @@ testConvertDataDecls ++ "(Foo Identity.Shape Identity.Pos) := { nf' := nf'Foo }. " ++ "Instance NormalformBar {Shape : Type} {Pos : Shape -> Type} " ++ ": Normalform Shape Pos (Bar Shape Pos) " - ++ "(Bar Identity.Shape Identity.Pos) := { nf' := nf'Bar }." + ++ "(Bar Identity.Shape Identity.Pos) := { nf' := nf'Bar }. " + ++ "(* ShareableArgs instances for Foo, Bar *) " + ++ "Fixpoint shareArgsFoo {Shape : Type} {Pos : Shape -> Type} " + ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " + ++ "(x : Foo Shape Pos) " + ++ ": Free Shape Pos (Foo Shape Pos) := let 'foo fx := x in " + ++ "cbneed Shape Pos shareArgsBar fx >>= (fun sx => " + ++ "pure (foo sx)) with " + ++ "shareArgsBar {Shape : Type} {Pos : Shape -> Type} " + ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " + ++ "(x : Bar Shape Pos) : Free Shape Pos (Bar Shape Pos) " + ++ ":= let 'bar fx := x in " + ++ "cbneed Shape Pos shareArgsFoo fx >>= (fun sx => " + ++ "pure (bar sx)). " + ++ "Instance ShareableArgsFoo {Shape : Type} " + ++ "{Pos : Shape -> Type} " + ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " + ++ ": ShareableArgs Shape Pos (Foo Shape Pos) " + ++ ":= { shareArgs := shareArgsFoo }. " + ++ "Instance ShareableArgsBar {Shape : Type} " + ++ "{Pos : Shape -> Type} " + ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " + ++ ": ShareableArgs Shape Pos (Bar Shape Pos) " + ++ ":= { shareArgs := shareArgsBar }. " context "Generation of induction schemes" $ do it "creates a correct induction scheme" $ shouldSucceedWith $ do "Foo" <- defineTestTypeCon "Foo" 1 ["Foo"] @@ -486,6 +603,21 @@ testConvertDataDecls ++ ": Normalform Shape Pos (Foo Shape Pos a) " ++ "(Foo Identity.Shape Identity.Pos b) " ++ ":= { nf' := nf'Foo_ }. " + ++ "(* ShareableArgs instance for Foo *) " + ++ "Fixpoint shareArgsFoo_ {Shape : Type} {Pos : Shape -> Type} " + ++ "{a : Type} `{Injectable Share.Shape Share.Pos Shape Pos} " + ++ "`{ShareableArgs Shape Pos a} (x : Foo Shape Pos a) " + ++ ": Free Shape Pos (Foo Shape Pos a) := let 'foo fx fx0 fx1 := x " + ++ "in cbneed Shape Pos shareArgsFoo_ fx >>= (fun sx => " + ++ "cbneed Shape Pos shareArgs fx0 >>= (fun sx0 => " + ++ "cbneed Shape Pos shareArgsFoo_ fx1 >>= (fun sx1 => " + ++ "pure (foo sx sx0 sx1)))). " + ++ "Instance ShareableArgsFoo_ {Shape : Type} " + ++ "{Pos : Shape -> Type} {a : Type} " + ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " + ++ "`{ShareableArgs Shape Pos a} " + ++ ": ShareableArgs Shape Pos (Foo Shape Pos a) " + ++ ":= { shareArgs := shareArgsFoo_ }. " context "Generation of qualified smart constructor notations" $ do it "produces qualified notations for a single type correctly" $ shouldSucceedWith From f07e6d350e67f58ea86ac00235011b57720eab11 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Tue, 15 Sep 2020 20:11:01 +0200 Subject: [PATCH 058/120] Apply HLint hint #150 #151 --- src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 6e3739a4..72c3003f 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -726,8 +726,7 @@ generateTypeclassInstances dataDecls = do (targetType, targetVars) <- toCoqType "b" idShapeAndPos t -- For each type variable ai, build a constraint -- `{Normalform Shape Pos ai bi}. - let constraints = map (uncurry Coq.Base.normalformBinder) - (zip sourceVars targetVars) + let constraints = zipWith Coq.Base.normalformBinder sourceVars targetVars let varBinder = [typeVarBinder (sourceVars ++ targetVars) | not (null sourceVars)] let binders = varBinder ++ constraints @@ -825,9 +824,8 @@ generateTypeclassInstances dataDecls = do where buildShareArgsValue' :: [Coq.Qualid] -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term - buildShareArgsValue' vals [] - = (generatePure (Coq.app (Coq.Qualid consName) - (map Coq.Qualid (reverse vals)))) + buildShareArgsValue' vals [] = generatePure + (Coq.app (Coq.Qualid consName) (map Coq.Qualid (reverse vals))) buildShareArgsValue' vals ((t, varName) : consVars) = do sx <- freshCoqQualid ("s" ++ freshArgPrefix) rhs <- buildShareArgsValue' (sx : vals) consVars From df40a5f2df933e772f6980f9033dc7a7f81d46b0 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Tue, 15 Sep 2020 21:11:36 +0200 Subject: [PATCH 059/120] Add tests for generated ShareableArgs instances #150 #151 --- example/Proofs/Normalform.hs | 42 +++++++++++++++++ example/Proofs/NormalformProofs.v | 76 ++++++++++++++++++++++++------- 2 files changed, 102 insertions(+), 16 deletions(-) diff --git a/example/Proofs/Normalform.hs b/example/Proofs/Normalform.hs index ce43ce04..93af54f0 100644 --- a/example/Proofs/Normalform.hs +++ b/example/Proofs/Normalform.hs @@ -2,9 +2,17 @@ -- instances are generated correctly. module Proofs.Normalform where +-- Prelude head function +head :: [a] -> a +head (x : _) = x + -- Basic recursive data type data MyList a = MyNil | MyCons a (MyList a) +-- Custom head function +myHead :: MyList a -> a +myHead (MyCons x _) = x + -- Mutually recursive data types data Foo a = Foo (Bar a) @@ -13,5 +21,39 @@ data Bar a = Bar (Foo a) | Baz -- Data type with 'hidden' recursion data Tree a = Leaf | Branch a [Tree a] +-- The root of a non-empty tree +root :: Tree a -> a +root (Branch x _) = x + +-- The root of the leftmost child of a tree with a non-empty leftmost child +headRoot :: Tree a -> a +headRoot (Branch _ ts) = root (head ts) + -- Data type with multiple type vars data Map k v = Empty | Entry k v (Map k v) + +-- The first entry of a non-empty map +firstMapEntry :: Map k v -> v +firstMapEntry (Entry _ v _) = v + +-- A function that shares a data structure, transforms +-- it into a Bool twice and connects the results with a +-- disjunction. +doubleDisjunction :: a -> (a -> Bool) -> Bool +doubleDisjunction x f = let y = x in f y || f y + +-- doubleDisjunction specialized for MyList +doubleDisjunctionHead :: MyList Bool -> Bool +doubleDisjunctionHead l = doubleDisjunction l myHead + +-- doubleDisjunction specialized for Tree +doubleDisjunctionRoot :: Tree Bool -> Bool +doubleDisjunctionRoot t = doubleDisjunction t root + +-- doubleDisjunction specialized for Tree +doubleDisjunctionHeadRoot :: Tree Bool -> Bool +doubleDisjunctionHeadRoot t = doubleDisjunction t headRoot + +-- doubleDisjunction specialized for Map +doubleDisjunctionMap :: Map Bool Bool -> Bool +doubleDisjunctionMap m = doubleDisjunction m firstMapEntry diff --git a/example/Proofs/NormalformProofs.v b/example/Proofs/NormalformProofs.v index e5159710..336fecc3 100644 --- a/example/Proofs/NormalformProofs.v +++ b/example/Proofs/NormalformProofs.v @@ -2,6 +2,7 @@ some data types in a nondeterministic context. *) From Base Require Import Free. +From Base Require Import Free.Handlers. From Base Require Import Free.Instance.Identity. From Base Require Import Free.Instance.ND. From Base Require Import Free.Util.Search. @@ -12,18 +13,6 @@ From Generated Require Import Proofs.Normalform. Require Import Lists.List. Import List.ListNotations. -(* Shortcuts to handle a program. *) - -(* Shortcut to evaluate a non-deterministic program to a result list. - list without normalization. *) -Definition evalND {A : Type} (p : Free _ _ A) -:= @collectVals A (run (runChoice p)). - -(* Handle a non-deterministic program after normalization. *) -Definition evalNDNF {A B : Type} - `{Normalform _ _ A B} - p := evalND (nf p). - (* Shortcuts for the Identity effect (i.e. the lack of an effect). *) Notation IdS := Identity.Shape. Notation IdP := Identity.Pos. @@ -50,6 +39,12 @@ Section Data. (True' ? False') (MyNil Shape Pos)). + (* [true ? false] *) + Definition ndList2 `{ND} : Free Shape Pos (MyList Shape Pos Bool_) + := MyCons Shape Pos + (True' ? False') + (MyNil Shape Pos). + (* (foo (bar (foo baz))) ? (foo baz) *) Definition ndFoo `{ND} : Free Shape Pos (Foo Shape Pos Bool_) := Foo0 Shape Pos @@ -69,6 +64,14 @@ Section Data. (Leaf Shape Pos) (Nil Shape Pos))). + (* branch true [branch true ? false []] *) + Definition ndTree2 `{ND} : Free Shape Pos (Tree Shape Pos Bool_) + := Branch Shape Pos + True' + (Cons Shape Pos + (Branch Shape Pos (True' ? False') (Nil Shape Pos)) + (Nil Shape Pos)). + (* (true -> (true ? false)) : ([] ? [(true ? false) -> false]) *) Definition ndMap `{ND} : Free Shape Pos (Map Shape Pos Bool_ Bool_) := Entry0 Shape Pos @@ -83,13 +86,17 @@ Section Data. End Data. Arguments ndList {_} {_} {_}. +Arguments ndList2 {_} {_} {_}. Arguments ndFoo {_} {_} {_}. Arguments ndTree {_} {_} {_}. +Arguments ndTree2 {_} {_} {_}. Arguments ndMap {_} {_} {_}. +(* Tests for the generated Normalform instances. *) + (* true : ([] ? [true ? false]) --> [ [true], [true, true], [true, false] ] *) -Example nondeterministic_list : evalNDNF ndList +Example nondeterministic_list : handleND ndList = [ myCons (pure true) (MyNil IdS IdP) ; myCons (pure true) (MyCons IdS IdP (pure true) (MyNil IdS IdP)) ; myCons (pure true) (MyCons IdS IdP (pure false) (MyNil IdS IdP)) @@ -98,7 +105,7 @@ Proof. trivial. Qed. (* (foo baz) ? (foo (bar (foo baz))) --> [ foo baz, foo (bar (foo baz)) ] *) -Example nondeterministic_foo : evalNDNF ndFoo +Example nondeterministic_foo : handleND ndFoo = [ foo (Bar0 IdS IdP (Foo0 IdS IdP (Baz IdS IdP))) ; foo (Baz IdS IdP) ]. @@ -107,7 +114,7 @@ Proof. trivial. Qed. (* branch (true ? false) (leaf : ([] ? [leaf])) --> [ branch true leaf, branch true [leaf, leaf] , branch false leaf, branch false [leaf, leaf] ] *) -Example nondeterministic_tree : evalNDNF ndTree +Example nondeterministic_tree : handleND ndTree = [ branch (pure true) (Cons IdS IdP (Leaf IdS IdP) (Nil IdS IdP)) ; branch (pure true) (Cons IdS IdP (Leaf IdS IdP) (Cons IdS IdP (Leaf IdS IdP) (Nil IdS IdP))) @@ -121,7 +128,7 @@ Proof. trivial. Qed. --> [ [true -> true] , [true -> true, true -> false] , [true -> true, false -> false], [false -> true] , [false -> true, true -> false], [false -> true, false -> false] ] *) -Example nondeterministic_map : evalNDNF ndMap +Example nondeterministic_map : handleND ndMap = [ entry (pure true) (pure true) (Empty IdS IdP) ; entry (pure true) (pure true) (Entry0 IdS IdP (pure true) (pure false) (Empty IdS IdP)) @@ -134,3 +141,40 @@ Example nondeterministic_map : evalNDNF ndMap (Entry0 IdS IdP (pure false) (pure false) (Empty IdS IdP)) ]. Proof. trivial. Qed. + +(* Tests for the generated ShareableArgs instances. *) + +(* let x = [true ? false] in myHead x || myHead x + --> true || true ? false || false + --> true ? false *) +Example deepSharingNDList +: handleShareND (doubleDisjunctionHead _ _ (Cbneed _ _) (ND.Partial _ _) ndList2) += [true;false]. +Proof. trivial. Qed. + +(* let x = branch (true ? false) (leaf : ([] ? [leaf])) + in root x || root x + --> true || true ? false || false + --> true ? false *) +Example deepSharingNDTree +: handleShareND (doubleDisjunctionRoot _ _ (Cbneed _ _) (ND.Partial _ _) ndTree) += [true;false]. +Proof. trivial. Qed. + +(* let x = branch true [branch true ? false []] + in headRoot x || headRoot x + --> true || true ? false || false + --> true ? false *) +Example deepSharingNDTree2 +: handleShareND (doubleDisjunctionHeadRoot _ _ (Cbneed _ _) (ND.Partial _ _) ndTree2) += [true;false]. +Proof. trivial. Qed. + +(* let x = true -> (true ? false)) : ([] ? [(true ? false) -> false] + in firstMapEntry x || firstMapEntry x + --> true || true ? false || false + --> true ? false *) +Example deepSharingNDMap +: handleShareND (doubleDisjunctionMap _ _ (Cbneed _ _) (ND.Partial _ _) ndMap) += [true;false]. +Proof. trivial. Qed. From c0f3304c6409f1581d38c9df83028427e1d38d89 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Tue, 15 Sep 2020 21:16:07 +0200 Subject: [PATCH 060/120] Rename Normalform and NormalformProofs #150 #151 --- .../Proofs/{Normalform.hs => TypeclassInstances.hs} | 4 ++-- .../{NormalformProofs.v => TypeclassInstancesProofs.v} | 10 +++++----- 2 files changed, 7 insertions(+), 7 deletions(-) rename example/Proofs/{Normalform.hs => TypeclassInstances.hs} (94%) rename example/Proofs/{NormalformProofs.v => TypeclassInstancesProofs.v} (96%) diff --git a/example/Proofs/Normalform.hs b/example/Proofs/TypeclassInstances.hs similarity index 94% rename from example/Proofs/Normalform.hs rename to example/Proofs/TypeclassInstances.hs index 93af54f0..2c1a3d2d 100644 --- a/example/Proofs/Normalform.hs +++ b/example/Proofs/TypeclassInstances.hs @@ -1,6 +1,6 @@ -- | This example defines some data types to check whether the [Normalform] --- instances are generated correctly. -module Proofs.Normalform where +-- and [ShareableArgs] instances are generated correctly. +module Proofs.TypeclassInstances where -- Prelude head function head :: [a] -> a diff --git a/example/Proofs/NormalformProofs.v b/example/Proofs/TypeclassInstancesProofs.v similarity index 96% rename from example/Proofs/NormalformProofs.v rename to example/Proofs/TypeclassInstancesProofs.v index 336fecc3..c79c7600 100644 --- a/example/Proofs/NormalformProofs.v +++ b/example/Proofs/TypeclassInstancesProofs.v @@ -8,7 +8,7 @@ From Base Require Import Free.Instance.ND. From Base Require Import Free.Util.Search. From Base Require Import Prelude. -From Generated Require Import Proofs.Normalform. +From Generated Require Import Proofs.TypeclassInstances. Require Import Lists.List. Import List.ListNotations. @@ -124,7 +124,7 @@ Example nondeterministic_tree : handleND ndTree ]. Proof. trivial. Qed. -(* (true -> (true ? false)) : ([] ? [(true ? false) -> false]) +(* (true -> (true ? false)) : ([] ? [(true ? false) -> false]) --> [ [true -> true] , [true -> true, true -> false] , [true -> true, false -> false], [false -> true] , [false -> true, true -> false], [false -> true, false -> false] ] *) @@ -144,10 +144,10 @@ Proof. trivial. Qed. (* Tests for the generated ShareableArgs instances. *) -(* let x = [true ? false] in myHead x || myHead x +(* let x = [true ? false] in myHead x || myHead x --> true || true ? false || false --> true ? false *) -Example deepSharingNDList +Example deepSharingNDList : handleShareND (doubleDisjunctionHead _ _ (Cbneed _ _) (ND.Partial _ _) ndList2) = [true;false]. Proof. trivial. Qed. @@ -156,7 +156,7 @@ Proof. trivial. Qed. in root x || root x --> true || true ? false || false --> true ? false *) -Example deepSharingNDTree +Example deepSharingNDTree : handleShareND (doubleDisjunctionRoot _ _ (Cbneed _ _) (ND.Partial _ _) ndTree) = [true;false]. Proof. trivial. Qed. From 627002bac788cc93e225b8ed806b1600ab7be5af Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Tue, 15 Sep 2020 21:19:09 +0200 Subject: [PATCH 061/120] Format code with Floskell #150 #151 --- example/Proofs/TypeclassInstances.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/example/Proofs/TypeclassInstances.hs b/example/Proofs/TypeclassInstances.hs index 2c1a3d2d..c3bacdd5 100644 --- a/example/Proofs/TypeclassInstances.hs +++ b/example/Proofs/TypeclassInstances.hs @@ -39,8 +39,9 @@ firstMapEntry (Entry _ v _) = v -- A function that shares a data structure, transforms -- it into a Bool twice and connects the results with a -- disjunction. -doubleDisjunction :: a -> (a -> Bool) -> Bool -doubleDisjunction x f = let y = x in f y || f y +doubleDisjunction :: a -> (a -> Bool) -> Bool +doubleDisjunction x f = let y = x + in f y || f y -- doubleDisjunction specialized for MyList doubleDisjunctionHead :: MyList Bool -> Bool From 72f1150eadf96244832372a0ed2b36ba2a03f931 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Tue, 15 Sep 2020 21:30:12 +0200 Subject: [PATCH 062/120] Fix indentation of Haddock comment #150 #151 --- src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 72c3003f..6be8feba 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -361,7 +361,7 @@ convertDataDecl (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do fArgTypes <- mapM convertType argTypes (argIdents, argBinders) <- mapAndUnzipM convertAnonymousArg (map Just argTypes) - let + let -- We need an induction hypothesis for every argument that has the same -- type as the constructor but lifted into the free monad. addHypotheses' :: [(Coq.Term, Coq.Qualid)] -> Coq.Term -> Coq.Term @@ -816,8 +816,8 @@ generateTypeclassInstances dataDecls = do let funcRetType = applyFree coqType return (binders, topLevelVarBinder, funcRetType, instanceRetType) - -- | Shares all arguments of the given constructor and reconstructs the - -- value with the shared components. + -- | Shares all arguments of the given constructor and reconstructs the + -- value with the shared components. buildShareArgsValue :: TypeMap -> Coq.Qualid -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term buildShareArgsValue nameMap consName = buildShareArgsValue' [] From 8f7080f7824e8e953eb1a8585399764998065431 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Tue, 15 Sep 2020 21:35:59 +0200 Subject: [PATCH 063/120] Format code with Floskell #150 #151 --- src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 6be8feba..b38be49f 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -361,7 +361,7 @@ convertDataDecl (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do fArgTypes <- mapM convertType argTypes (argIdents, argBinders) <- mapAndUnzipM convertAnonymousArg (map Just argTypes) - let + let -- We need an induction hypothesis for every argument that has the same -- type as the constructor but lifted into the free monad. addHypotheses' :: [(Coq.Term, Coq.Qualid)] -> Coq.Term -> Coq.Term From bb296e3413cb95738de700eb1a1caa1c9ede7447 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Tue, 15 Sep 2020 23:00:02 +0200 Subject: [PATCH 064/120] Add a few more example type to test generated instances #150 #151 --- example/Proofs/TypeclassInstances.hs | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/example/Proofs/TypeclassInstances.hs b/example/Proofs/TypeclassInstances.hs index c3bacdd5..db51b528 100644 --- a/example/Proofs/TypeclassInstances.hs +++ b/example/Proofs/TypeclassInstances.hs @@ -58,3 +58,24 @@ doubleDisjunctionHeadRoot t = doubleDisjunction t headRoot -- doubleDisjunction specialized for Map doubleDisjunctionMap :: Map Bool Bool -> Bool doubleDisjunctionMap m = doubleDisjunction m firstMapEntry + +-- Additional data types to check that the generated +-- instances are valid Coq code +--Types with potential name conflict +data T a = TCons a + +data T_ = T_Cons + +-- Type with nested recursion and type variable instantiation +data Rose a = Rose (Rose Integer, Rose a) + +-- Mutually recursive types with nested recursion and type variable +-- instantiation +data A a = ConsA [B Bool] | AVal a + +data B a = ConsB [A Bool] | BVal a + +-- Indirect recursion hidden in a type synonym +type IntGatherings = MyList (Gathering Integer) + +data Gathering a = Many IntGatherings | Single a From 4f599252f142996b2c135d10fb0fe2b51fa7b1cf Mon Sep 17 00:00:00 2001 From: MajaRet <61735247+MajaRet@users.noreply.github.com> Date: Wed, 16 Sep 2020 07:17:00 +0200 Subject: [PATCH 065/120] Add periods to comments #150 #151 --- example/Proofs/TypeclassInstances.hs | 34 ++++++++++++++-------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/example/Proofs/TypeclassInstances.hs b/example/Proofs/TypeclassInstances.hs index db51b528..6d6cf90c 100644 --- a/example/Proofs/TypeclassInstances.hs +++ b/example/Proofs/TypeclassInstances.hs @@ -6,33 +6,33 @@ module Proofs.TypeclassInstances where head :: [a] -> a head (x : _) = x --- Basic recursive data type +-- Basic recursive data type. data MyList a = MyNil | MyCons a (MyList a) --- Custom head function +-- Custom head function. myHead :: MyList a -> a myHead (MyCons x _) = x --- Mutually recursive data types +-- Mutually recursive data types. data Foo a = Foo (Bar a) data Bar a = Bar (Foo a) | Baz --- Data type with 'hidden' recursion +-- Data type with 'hidden' recursion. data Tree a = Leaf | Branch a [Tree a] --- The root of a non-empty tree +-- The root of a non-empty tree. root :: Tree a -> a root (Branch x _) = x --- The root of the leftmost child of a tree with a non-empty leftmost child +-- The root of the leftmost child of a tree with a non-empty leftmost child. headRoot :: Tree a -> a headRoot (Branch _ ts) = root (head ts) --- Data type with multiple type vars +-- Data type with multiple type vars. data Map k v = Empty | Entry k v (Map k v) --- The first entry of a non-empty map +-- The first entry of a non-empty map. firstMapEntry :: Map k v -> v firstMapEntry (Entry _ v _) = v @@ -43,39 +43,39 @@ doubleDisjunction :: a -> (a -> Bool) -> Bool doubleDisjunction x f = let y = x in f y || f y --- doubleDisjunction specialized for MyList +-- doubleDisjunction specialized for MyList. doubleDisjunctionHead :: MyList Bool -> Bool doubleDisjunctionHead l = doubleDisjunction l myHead --- doubleDisjunction specialized for Tree +-- doubleDisjunction specialized for Tree. doubleDisjunctionRoot :: Tree Bool -> Bool doubleDisjunctionRoot t = doubleDisjunction t root --- doubleDisjunction specialized for Tree +-- doubleDisjunction specialized for Tree. doubleDisjunctionHeadRoot :: Tree Bool -> Bool doubleDisjunctionHeadRoot t = doubleDisjunction t headRoot --- doubleDisjunction specialized for Map +-- doubleDisjunction specialized for Map. doubleDisjunctionMap :: Map Bool Bool -> Bool doubleDisjunctionMap m = doubleDisjunction m firstMapEntry -- Additional data types to check that the generated --- instances are valid Coq code ---Types with potential name conflict +-- instances are valid Coq code. +--Types with potential name conflict. data T a = TCons a data T_ = T_Cons --- Type with nested recursion and type variable instantiation +-- Type with nested recursion and type variable instantiation. data Rose a = Rose (Rose Integer, Rose a) -- Mutually recursive types with nested recursion and type variable --- instantiation +-- instantiation. data A a = ConsA [B Bool] | AVal a data B a = ConsB [A Bool] | BVal a --- Indirect recursion hidden in a type synonym +-- Indirect recursion hidden in a type synonym. type IntGatherings = MyList (Gathering Integer) data Gathering a = Many IntGatherings | Single a From 55edb95ac18fe27a7ab7085ea1bb197edeba6a1f Mon Sep 17 00:00:00 2001 From: Marvin Lira <39922784+marvin2706@users.noreply.github.com> Date: Wed, 16 Sep 2020 11:00:00 +0200 Subject: [PATCH 066/120] Fix typo --- src/lib/FreeC/Pass/PragmaPass.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib/FreeC/Pass/PragmaPass.hs b/src/lib/FreeC/Pass/PragmaPass.hs index 11b1fe7a..7b2fe268 100644 --- a/src/lib/FreeC/Pass/PragmaPass.hs +++ b/src/lib/FreeC/Pass/PragmaPass.hs @@ -20,7 +20,7 @@ -- -- == Error Cases -- --- * If there is a pragmaof the form @{-# FreeC f DECREASES ON xᵢ #-}@ or +-- * If there is a pragma of the form @{-# FreeC f DECREASES ON xᵢ #-}@ or -- @{-# FreeC f DECREASES ON ARGUMENT i #-}@, but there is no such -- function declaration or the function does not have an argument with -- the specified name or at the specified position, a fatal error is From fd223132402e71d9393bcbbc837c83ca8e95c42b Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Thu, 17 Sep 2020 11:55:48 +0200 Subject: [PATCH 067/120] Remove redundant application of `testEffectAnalysisPass` #199 --- src/test/FreeC/PipelineTests.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/test/FreeC/PipelineTests.hs b/src/test/FreeC/PipelineTests.hs index e9dba831..59472727 100644 --- a/src/test/FreeC/PipelineTests.hs +++ b/src/test/FreeC/PipelineTests.hs @@ -20,6 +20,5 @@ testPipeline = do testEtaConversionPass testExportPass testKindCheckPass - testEffectAnalysisPass testResolverPass testTypeInferencePass From e8cc26fe74ea372fa9c61934a91c039816c7ea99 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Thu, 17 Sep 2020 11:59:06 +0200 Subject: [PATCH 068/120] Apply suggestions from code review #198 Co-authored-by: stu204767 <63296935+stu204767@users.noreply.github.com> --- src/test/FreeC/Frontend/Haskell/SimplifierTests.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/test/FreeC/Frontend/Haskell/SimplifierTests.hs b/src/test/FreeC/Frontend/Haskell/SimplifierTests.hs index 3391e185..b0311b62 100644 --- a/src/test/FreeC/Frontend/Haskell/SimplifierTests.hs +++ b/src/test/FreeC/Frontend/Haskell/SimplifierTests.hs @@ -21,7 +21,8 @@ parseAndSimplifyExpr = (parseHaskell . mkSrcFile "") >=> simplifyExpr -- | Parses the given Haskell and IR expressions, converts the Haskell --- expression to IR . +-- expression to IR and sets the expectation that the given IR expression is +-- produced. shouldSimplifyExpr :: String -> String -> Simplifier Expectation shouldSimplifyExpr input expectedOutput = do output <- parseAndSimplifyExpr input @@ -39,7 +40,7 @@ testSimplifier = describe "FreeC.Frontend.Haskell.Simplifier" $ do -- | Test group for 'simplifyExpr' tests. testSimplifyExpr :: Spec testSimplifyExpr = context "simplifyExpr" $ do - it "simplifies single variable pattern case expression to lambda abstractions" + it "simplifies single-variable-pattern case expressions to lambda abstractions" $ shouldSucceedWith $ do "case e of { x -> e' }" `shouldSimplifyExpr` "(\\x -> e') e" From 76f018e97820f0fffe9b197b6a67be1eeb34f2ee Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Thu, 17 Sep 2020 12:07:04 +0200 Subject: [PATCH 069/120] Rephrase test module comments #198 --- src/test/FreeC/Backend/Agda/Tests.hs | 5 +++-- src/test/FreeC/Backend/Coq/ConverterTests.hs | 3 ++- src/test/FreeC/Backend/Coq/Tests.hs | 4 ++-- src/test/FreeC/Frontend/Haskell/Tests.hs | 5 +++-- src/test/FreeC/Frontend/IR/Tests.hs | 4 ++-- src/test/FreeC/IR/Tests.hs | 4 ++-- 6 files changed, 14 insertions(+), 11 deletions(-) diff --git a/src/test/FreeC/Backend/Agda/Tests.hs b/src/test/FreeC/Backend/Agda/Tests.hs index 075a695d..7caf7e7c 100644 --- a/src/test/FreeC/Backend/Agda/Tests.hs +++ b/src/test/FreeC/Backend/Agda/Tests.hs @@ -1,4 +1,5 @@ --- | Test group for tests of modules below @FreeC.Backend.Agda@. +-- | This module contains tests for modules with the +-- @FreeC.Backend.Agda@ prefix. module FreeC.Backend.Agda.Tests ( testAgdaBackend ) where import Test.Hspec @@ -6,7 +7,7 @@ import Test.Hspec import FreeC.Backend.Agda.Converter.FuncDeclTests import FreeC.Backend.Agda.Converter.TypeDeclTests --- | Test group for tests of modules below @FreeC.Backend.Agda@. +-- | Test group for tests of modules with the @FreeC.Backend.Agda@ prefix. testAgdaBackend :: Spec testAgdaBackend = do testConvertDataDecls diff --git a/src/test/FreeC/Backend/Coq/ConverterTests.hs b/src/test/FreeC/Backend/Coq/ConverterTests.hs index e3e05980..9e1ab9b1 100644 --- a/src/test/FreeC/Backend/Coq/ConverterTests.hs +++ b/src/test/FreeC/Backend/Coq/ConverterTests.hs @@ -1,4 +1,5 @@ --- | This module contains tests for modules below @FreeC.Backend.Coq.Converter@. +-- | This module contains tests for modules with the +-- @FreeC.Backend.Coq.Converter@ prefix. module FreeC.Backend.Coq.ConverterTests where import Test.Hspec diff --git a/src/test/FreeC/Backend/Coq/Tests.hs b/src/test/FreeC/Backend/Coq/Tests.hs index e7192a10..604d8c2c 100644 --- a/src/test/FreeC/Backend/Coq/Tests.hs +++ b/src/test/FreeC/Backend/Coq/Tests.hs @@ -1,4 +1,4 @@ --- | Test group for tests of modules below @FreeC.Backend.Coq@. +-- | This module contains tests for modules with the @FreeC.Backend.Coq@ prefix. module FreeC.Backend.Coq.Tests ( testCoqBackend ) where import Test.Hspec @@ -7,7 +7,7 @@ import FreeC.Backend.Coq.Analysis.ConstantArgumentsTests import FreeC.Backend.Coq.Analysis.DecreasingArgumentsTests import FreeC.Backend.Coq.ConverterTests --- | Test group for tests of modules below @FreeC.Backend.Coq@. +-- | Test group for tests of modules with the @FreeC.Backend.Coq@ prefix. testCoqBackend :: Spec testCoqBackend = do testConstantArguments diff --git a/src/test/FreeC/Frontend/Haskell/Tests.hs b/src/test/FreeC/Frontend/Haskell/Tests.hs index 37093521..1c1d9a36 100644 --- a/src/test/FreeC/Frontend/Haskell/Tests.hs +++ b/src/test/FreeC/Frontend/Haskell/Tests.hs @@ -1,11 +1,12 @@ --- | Test group for tests of modules below @FreeC.Frontend.Haskell@. +-- | This module contains tests for modules with the @FreeC.Frontend.Haskell@ +-- prefix. module FreeC.Frontend.Haskell.Tests ( testHaskellFrontend ) where import Test.Hspec import FreeC.Frontend.Haskell.SimplifierTests --- | Test group for tests of modules below @FreeC.Frontend.Haskell@. +-- | Test group for tests of modules with the @FreeC.Frontend.Haskell@ prefix. testHaskellFrontend :: Spec testHaskellFrontend = do testSimplifier diff --git a/src/test/FreeC/Frontend/IR/Tests.hs b/src/test/FreeC/Frontend/IR/Tests.hs index 6a80337f..4a3698a3 100644 --- a/src/test/FreeC/Frontend/IR/Tests.hs +++ b/src/test/FreeC/Frontend/IR/Tests.hs @@ -1,4 +1,4 @@ --- | Test group for tests of modules below @FreeC.Frontend.IR@. +-- | This module contains tests for modules with the @FreeC.Frontend.IR@ prefix. module FreeC.Frontend.IR.Tests ( testIRFrontend ) where import Test.Hspec @@ -6,7 +6,7 @@ import Test.Hspec import FreeC.Frontend.IR.ParserTests import FreeC.Frontend.IR.ScannerTests --- | Test group for tests of modules below @FreeC.Frontend.IR@. +-- | Test group for tests of modules with the @FreeC.Frontend.IR@ prefix. testIRFrontend :: Spec testIRFrontend = do testIRScanner diff --git a/src/test/FreeC/IR/Tests.hs b/src/test/FreeC/IR/Tests.hs index 5de89d0e..bff732da 100644 --- a/src/test/FreeC/IR/Tests.hs +++ b/src/test/FreeC/IR/Tests.hs @@ -1,4 +1,4 @@ --- | This module contains tests for modules that are defined below @FreeC.IR@. +-- | This module contains tests for modules with the @FreeC.IR@ prefix. module FreeC.IR.Tests ( testIR ) where import Test.Hspec @@ -12,7 +12,7 @@ import FreeC.IR.SyntaxTests import FreeC.IR.TypeSynExpansionTests import FreeC.IR.UnificationTests --- | Test group for tests of modules below @FreeC.IR@. +-- | Test group for tests of modules with the @FreeC.IR@ prefix. testIR :: Spec testIR = do testInlining From 839c1095c62f19616bf3b3802a828f114017ea8c Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Thu, 17 Sep 2020 12:28:23 +0200 Subject: [PATCH 070/120] Format code #198 --- src/test/FreeC/Frontend/Haskell/SimplifierTests.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/test/FreeC/Frontend/Haskell/SimplifierTests.hs b/src/test/FreeC/Frontend/Haskell/SimplifierTests.hs index b0311b62..98204119 100644 --- a/src/test/FreeC/Frontend/Haskell/SimplifierTests.hs +++ b/src/test/FreeC/Frontend/Haskell/SimplifierTests.hs @@ -40,7 +40,8 @@ testSimplifier = describe "FreeC.Frontend.Haskell.Simplifier" $ do -- | Test group for 'simplifyExpr' tests. testSimplifyExpr :: Spec testSimplifyExpr = context "simplifyExpr" $ do - it "simplifies single-variable-pattern case expressions to lambda abstractions" + it + "simplifies single-variable-pattern case expressions to lambda abstractions" $ shouldSucceedWith $ do "case e of { x -> e' }" `shouldSimplifyExpr` "(\\x -> e') e" From 74815d60c17ccd0b9b1d11fab1ae0ecaa5d42745 Mon Sep 17 00:00:00 2001 From: Daniel Teut Date: Fri, 18 Sep 2020 02:11:54 +0200 Subject: [PATCH 071/120] Add `call` to let lifting #196 --- src/lib/FreeC/LiftedIR/Converter/Expr.hs | 64 +++++++++++++++++++----- 1 file changed, 51 insertions(+), 13 deletions(-) diff --git a/src/lib/FreeC/LiftedIR/Converter/Expr.hs b/src/lib/FreeC/LiftedIR/Converter/Expr.hs index cefe9a6b..e9816366 100644 --- a/src/lib/FreeC/LiftedIR/Converter/Expr.hs +++ b/src/lib/FreeC/LiftedIR/Converter/Expr.hs @@ -201,7 +201,7 @@ liftExpr' expr (_ : _) _ = reportFatal -- Application of an expression other than a function or constructor -- application. We use an as-pattern for @args@ such that we get a compile -- time warning when a node is added to the AST that we do not cover above. -liftExpr' expr [] args@(_ : _) +liftExpr' expr [] args @ (_ : _) = join $ generateApply <$> liftExpr expr <*> mapM liftExpr args ------------------------------------------------------------------------------- @@ -223,7 +223,7 @@ liftAlt (IR.Alt srcSpan conPat pats expr) = do -- are unwrapped using @>>=@. liftAlt' :: [IR.VarPat] -> IR.Expr -> Converter ([LIR.VarPat], LIR.Expr) liftAlt' [] expr = ([], ) <$> liftExpr expr -liftAlt' (pat@(IR.VarPat srcSpan name varType strict) : pats) expr +liftAlt' (pat @ (IR.VarPat srcSpan name varType strict) : pats) expr = localEnv $ do varType' <- LIR.liftVarPatType pat var <- renameAndDefineLIRVar srcSpan strict name varType @@ -332,14 +332,52 @@ rawBind srcSpan mx x varType expr = do -- The given expression is the right-hand side of the let. liftBinds :: [IR.Bind] -> IR.Expr -> Converter LIR.Expr liftBinds [] expr = liftExpr expr -liftBinds - ((IR.Bind srcSpan (IR.VarPat patSrcSpan ident varPatType isStrict) bindExpr) - : bs) expr = localEnv $ do - _ <- renameAndDefineLIRVar srcSpan isStrict ident varPatType - expr' <- liftBinds bs expr - patType' <- mapM LIR.liftType varPatType - varPat' <- makeVarPat patSrcSpan (IR.UnQual $ IR.Ident ident) patType' - shareType' <- mapM LIR.liftType' varPatType - bindExpr' <- liftExpr bindExpr - let shareExpr = LIR.Share srcSpan bindExpr' shareType' - return $ LIR.Bind srcSpan shareExpr (LIR.Lambda srcSpan [varPat'] expr') +liftBinds ((IR.Bind srcSpan varPat + @ (IR.VarPat patSrcSpan ident varPatType isStrict) bindExpr) + : bs) expr = localEnv $ do + _ <- renameAndDefineLIRVar srcSpan isStrict ident varPatType + expr' <- liftBinds bs expr + patType' <- mapM LIR.liftType varPatType + varPat' <- makeVarPat patSrcSpan (IR.varPatQName varPat) patType' + shareType' <- mapM LIR.liftType' varPatType + bindExpr' <- liftExpr bindExpr + let countExprs = expr : map IR.bindExpr bs + shareOp + = if sum (map (countVarInExpr $ IR.varPatQName varPat) countExprs) > 1 + then LIR.Share + else LIR.Call + shareExpr = shareOp srcSpan bindExpr' shareType' + return $ LIR.Bind srcSpan shareExpr (LIR.Lambda srcSpan [varPat'] expr') + +-- | Counts the number of times the variable with the given qualified name +-- occurs in the given expression. +countVarInExpr :: IR.QName -> IR.Expr -> Int +countVarInExpr varPat = countVarInExpr' + where + countVarInExpr' :: IR.Expr -> Int + countVarInExpr' IR.Con {} = 0 + countVarInExpr' (IR.Var _ varName _) + = if varPat == varName then 1 else 0 + countVarInExpr' (IR.App _ lhs rhs _) + = countVarInExpr' lhs + countVarInExpr' rhs + countVarInExpr' (IR.TypeAppExpr _ lhs _ _) = countVarInExpr' lhs + countVarInExpr' (IR.If _ cond true false _) + = countVarInExpr' cond + countVarInExpr' true `max` countVarInExpr' false + countVarInExpr' (IR.Case _ expr alts _) = countVarInExpr' expr + + maximum + (map (\(IR.Alt _ _ varPats rhs) -> countVarInBinds varPats rhs) alts) + countVarInExpr' IR.Undefined {} = 0 + countVarInExpr' IR.ErrorExpr {} = 0 + countVarInExpr' IR.IntLiteral {} = 0 + countVarInExpr' (IR.Lambda _ varPats expr _) = countVarInBinds varPats expr + countVarInExpr' (IR.Let _ binds expr _) = countVarInExpr' expr + + sum (map (countVarInExpr' . IR.bindExpr) binds) + + -- | Returns the number of all occurrences of the variable with the given name + -- in the given expression. + -- + -- Returns @0@ if the variable occurs in the given variable patterns. + countVarInBinds :: [IR.VarPat] -> IR.Expr -> Int + countVarInBinds varPats exprs + | any (\varPat' -> IR.varPatQName varPat' == varPat) varPats = 0 + | otherwise = countVarInExpr varPat exprs From 400a44bf2118d65d716debfa719d02f5d608b66f Mon Sep 17 00:00:00 2001 From: Daniel Teut Date: Fri, 18 Sep 2020 20:57:52 +0200 Subject: [PATCH 072/120] Add test cases for `call` operator #196 --- .../FreeC/Backend/Coq/Converter/ExprTests.hs | 46 ++++++++++++++++++- 1 file changed, 44 insertions(+), 2 deletions(-) diff --git a/src/test/FreeC/Backend/Coq/Converter/ExprTests.hs b/src/test/FreeC/Backend/Coq/Converter/ExprTests.hs index e2ad478e..2f8d0e19 100644 --- a/src/test/FreeC/Backend/Coq/Converter/ExprTests.hs +++ b/src/test/FreeC/Backend/Coq/Converter/ExprTests.hs @@ -277,12 +277,54 @@ testConvertLet = context "let expressions" $ do "x" <- defineTestVar "x" "y" <- defineTestVar "y" shouldConvertExprTo - "let {(x' :: Integer) = x; (y' :: Integer) = y} in (add x' y')" + "let {(x' :: Integer) = x; (y' :: Integer) = y} in add (add x' x') (add y' y')" $ "@share Shape Pos S (Integer Shape Pos) _ x" ++ " >>= (fun (x' : Free Shape Pos (Integer Shape Pos)) =>" ++ " @share Shape Pos S (Integer Shape Pos) _ y" ++ " >>= (fun (y' : Free Shape Pos (Integer Shape Pos)) =>" - ++ " add Shape Pos x' y'))" + ++ " add Shape Pos (add Shape Pos x' x') (add Shape Pos y' y')))" + it "translates a let expression with a single variable occurrence correctly" + $ shouldSucceedWith + $ do + "x" <- defineTestVar "x" + "a" <- defineTestTypeVar "a" + shouldConvertExprTo "let {(x' :: a) = x} in x'" + "@call Shape Pos S a x >>= (fun (x' : Free Shape Pos a) => x')" + it "ignores shadowed variables in case expressions" $ shouldSucceedWith $ do + (_, "Nil") <- defineTestCon "Nil" 0 "forall a. List a" + (_, "Cons") <- defineTestCon "Cons" 1 "forall a. a -> List a" + "f" <- defineTestFunc "f" 2 "forall a. a -> a -> a" + "x" <- defineTestVar "x" + "xs" <- defineTestVar "xs" + "a" <- defineTestTypeVar "a" + shouldConvertExprTo + "let {(x' :: a) = x} in case xs of {Cons x' -> f @a x' x'; Nil -> x'}" + $ "@call Shape Pos S a x >>= (fun (x' : Free Shape Pos a) =>" + ++ " xs >>= (fun xs_0 => match xs_0 with" + ++ " | cons x'0 => @f Shape Pos a x'0 x'0" + ++ " | nil => x'" + ++ " end))" + it "does not add occurrences over case branches" $ shouldSucceedWith $ do + (_, "Nil") <- defineTestCon "Nil" 0 "forall a. List a" + (_, "Cons") <- defineTestCon "Cons" 1 "forall a. a -> List a" + "x" <- defineTestVar "x" + "y" <- defineTestVar "y" + "xs" <- defineTestVar "xs" + "a" <- defineTestTypeVar "a" + shouldConvertExprTo + "let {(x' :: a) = x} in case xs of {Cons y -> x'; Nil -> x'}" + $ "@call Shape Pos S a x >>= (fun (x' : Free Shape Pos a) =>" + ++ " xs >>= (fun xs_0 => match xs_0 with" + ++ " | cons y0 => x'" + ++ " | nil => x'" + ++ " end))" + it "ignores shadowed variables in lambda expressions" $ shouldSucceedWith $ do + "f" <- defineTestFunc "f" 2 "forall a. a -> a -> a" + "x" <- defineTestVar "x" + "a" <- defineTestTypeVar "a" + shouldConvertExprTo "let {(x' :: a) = x} in \\(x' :: a) -> f @a x' x'" + $ "@call Shape Pos S a x >>= (fun (x' : Free Shape Pos a) =>" + ++ " pure (fun (x'0 : Free Shape Pos a) => @f Shape Pos a x'0 x'0))" ------------------------------------------------------------------------------- -- Lambda Abstractions -- From 706583e205b97c7479850e84bea98d08cc95821a Mon Sep 17 00:00:00 2001 From: Daniel Teut Date: Fri, 18 Sep 2020 21:14:15 +0200 Subject: [PATCH 073/120] Format code --- src/lib/FreeC/LiftedIR/Converter/Expr.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/lib/FreeC/LiftedIR/Converter/Expr.hs b/src/lib/FreeC/LiftedIR/Converter/Expr.hs index e9816366..13e79f0b 100644 --- a/src/lib/FreeC/LiftedIR/Converter/Expr.hs +++ b/src/lib/FreeC/LiftedIR/Converter/Expr.hs @@ -201,7 +201,7 @@ liftExpr' expr (_ : _) _ = reportFatal -- Application of an expression other than a function or constructor -- application. We use an as-pattern for @args@ such that we get a compile -- time warning when a node is added to the AST that we do not cover above. -liftExpr' expr [] args @ (_ : _) +liftExpr' expr [] args@(_ : _) = join $ generateApply <$> liftExpr expr <*> mapM liftExpr args ------------------------------------------------------------------------------- @@ -223,7 +223,7 @@ liftAlt (IR.Alt srcSpan conPat pats expr) = do -- are unwrapped using @>>=@. liftAlt' :: [IR.VarPat] -> IR.Expr -> Converter ([LIR.VarPat], LIR.Expr) liftAlt' [] expr = ([], ) <$> liftExpr expr -liftAlt' (pat @ (IR.VarPat srcSpan name varType strict) : pats) expr +liftAlt' (pat@(IR.VarPat srcSpan name varType strict) : pats) expr = localEnv $ do varType' <- LIR.liftVarPatType pat var <- renameAndDefineLIRVar srcSpan strict name varType @@ -333,7 +333,7 @@ rawBind srcSpan mx x varType expr = do liftBinds :: [IR.Bind] -> IR.Expr -> Converter LIR.Expr liftBinds [] expr = liftExpr expr liftBinds ((IR.Bind srcSpan varPat - @ (IR.VarPat patSrcSpan ident varPatType isStrict) bindExpr) + @(IR.VarPat patSrcSpan ident varPatType isStrict) bindExpr) : bs) expr = localEnv $ do _ <- renameAndDefineLIRVar srcSpan isStrict ident varPatType expr' <- liftBinds bs expr From 3ce77515ed22593953a73cec7bb9abe9522ee2d1 Mon Sep 17 00:00:00 2001 From: Daniel Teut Date: Fri, 18 Sep 2020 21:44:20 +0200 Subject: [PATCH 074/120] Fix unit tests #196 --- src/lib/FreeC/LiftedIR/Converter/Expr.hs | 5 ++--- .../FreeC/Backend/Coq/Converter/ExprTests.hs | 16 ++++++++-------- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/src/lib/FreeC/LiftedIR/Converter/Expr.hs b/src/lib/FreeC/LiftedIR/Converter/Expr.hs index 13e79f0b..7674b015 100644 --- a/src/lib/FreeC/LiftedIR/Converter/Expr.hs +++ b/src/lib/FreeC/LiftedIR/Converter/Expr.hs @@ -332,9 +332,8 @@ rawBind srcSpan mx x varType expr = do -- The given expression is the right-hand side of the let. liftBinds :: [IR.Bind] -> IR.Expr -> Converter LIR.Expr liftBinds [] expr = liftExpr expr -liftBinds ((IR.Bind srcSpan varPat - @(IR.VarPat patSrcSpan ident varPatType isStrict) bindExpr) - : bs) expr = localEnv $ do +liftBinds ((IR.Bind srcSpan varPat bindExpr) : bs) expr = localEnv $ do + let (IR.VarPat patSrcSpan ident varPatType isStrict) = varPat _ <- renameAndDefineLIRVar srcSpan isStrict ident varPatType expr' <- liftBinds bs expr patType' <- mapM LIR.liftType varPatType diff --git a/src/test/FreeC/Backend/Coq/Converter/ExprTests.hs b/src/test/FreeC/Backend/Coq/Converter/ExprTests.hs index 2f8d0e19..c2fe4e5e 100644 --- a/src/test/FreeC/Backend/Coq/Converter/ExprTests.hs +++ b/src/test/FreeC/Backend/Coq/Converter/ExprTests.hs @@ -300,10 +300,10 @@ testConvertLet = context "let expressions" $ do shouldConvertExprTo "let {(x' :: a) = x} in case xs of {Cons x' -> f @a x' x'; Nil -> x'}" $ "@call Shape Pos S a x >>= (fun (x' : Free Shape Pos a) =>" - ++ " xs >>= (fun xs_0 => match xs_0 with" - ++ " | cons x'0 => @f Shape Pos a x'0 x'0" - ++ " | nil => x'" - ++ " end))" + ++ " xs >>= (fun xs0 => match xs0 with" + ++ " | cons x'0 => @f Shape Pos a x'0 x'0" + ++ " | nil => x'" + ++ " end))" it "does not add occurrences over case branches" $ shouldSucceedWith $ do (_, "Nil") <- defineTestCon "Nil" 0 "forall a. List a" (_, "Cons") <- defineTestCon "Cons" 1 "forall a. a -> List a" @@ -314,10 +314,10 @@ testConvertLet = context "let expressions" $ do shouldConvertExprTo "let {(x' :: a) = x} in case xs of {Cons y -> x'; Nil -> x'}" $ "@call Shape Pos S a x >>= (fun (x' : Free Shape Pos a) =>" - ++ " xs >>= (fun xs_0 => match xs_0 with" - ++ " | cons y0 => x'" - ++ " | nil => x'" - ++ " end))" + ++ " xs >>= (fun xs0 => match xs0 with" + ++ " | cons y0 => x'" + ++ " | nil => x'" + ++ " end))" it "ignores shadowed variables in lambda expressions" $ shouldSucceedWith $ do "f" <- defineTestFunc "f" 2 "forall a. a -> a -> a" "x" <- defineTestVar "x" From 453fb4c267ef72606a5bbdf15c760d38aa7e86cf Mon Sep 17 00:00:00 2001 From: Daniel Teut Date: Sat, 19 Sep 2020 00:31:06 +0200 Subject: [PATCH 075/120] Fix typos #158 --- src/lib/FreeC/IR/Syntax/Expr.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/lib/FreeC/IR/Syntax/Expr.hs b/src/lib/FreeC/IR/Syntax/Expr.hs index 836c5f7d..57b63023 100644 --- a/src/lib/FreeC/IR/Syntax/Expr.hs +++ b/src/lib/FreeC/IR/Syntax/Expr.hs @@ -310,7 +310,7 @@ data VarPat = VarPat { varPatSrcSpan :: SrcSpan } deriving ( Eq, Show ) --- | Instance to get the name of a @let@-binding.. +-- | Instance to get the name of a @let@-binding. instance HasDeclIdent VarPat where declIdent varPat = DeclIdent (varPatSrcSpan varPat) (UnQual (Ident (varPatIdent varPat))) @@ -350,7 +350,7 @@ data Bind = Bind { bindSrcSpan :: SrcSpan, bindVarPat :: VarPat, bindExpr :: Expr } deriving ( Eq, Show ) --- | Instance to get the name of a @let@-binding.. +-- | Instance to get the name of a @let@-binding. instance HasDeclIdent Bind where declIdent = declIdent . bindVarPat From a983129815c38e47ca5459ab4f054721c526c7dd Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 20 Sep 2020 11:23:02 +0200 Subject: [PATCH 076/120] Apply suggestions #150 --- src/lib/FreeC/Backend/Coq/Base.hs | 40 ++- src/lib/FreeC/Backend/Coq/Converter/Free.hs | 2 +- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 332 +++++++++--------- 3 files changed, 203 insertions(+), 171 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Base.hs b/src/lib/FreeC/Backend/Coq/Base.hs index 1d32a306..514d7fce 100644 --- a/src/lib/FreeC/Backend/Coq/Base.hs +++ b/src/lib/FreeC/Backend/Coq/Base.hs @@ -30,10 +30,14 @@ module FreeC.Backend.Coq.Base , strategyArg , shareableArgs , shareableArgsBinder + , shareArgs , normalform , normalformBinder + , nf' + , nf , implicitArg , share + , cbneed -- * Effect Selection , selectExplicitArgs , selectImplicitArgs @@ -146,6 +150,7 @@ partialError = Coq.bare "error" qualifiedSmartConstructorModule :: Coq.Ident qualifiedSmartConstructorModule = Coq.ident "QualifiedSmartConstructorModule" +------------------------------------------------------------------------------- -- Sharing -- ------------------------------------------------------------------------------- -- | The Coq identifier for the @Share@ module. @@ -190,6 +195,25 @@ shareableArgsBinder typeArg = Coq.Generalized Coq.Implicit $ Coq.app (Coq.Qualid shareableArgs) $ map Coq.Qualid [shape, pos, typeArg] +-- | The Coq identifier of the @ShareableArgs@ class function. +shareArgs :: Coq.Qualid +shareArgs = Coq.bare "shareArgs" + +-- | The Coq identifier for an implicit argument. +implicitArg :: Coq.Term +implicitArg = Coq.Underscore + +-- | The Coq identifier for the @share@ operator. +share :: Coq.Qualid +share = Coq.bare "share" + +-- | The Coq identifier for the @cbneed@ operator. +cbneed :: Coq.Qualid +cbneed = Coq.bare "cbneed" + +------------------------------------------------------------------------------- +-- Handling -- +------------------------------------------------------------------------------- -- | The Coq identifier for the @Normalform@ type class. normalform :: Coq.Qualid normalform = Coq.bare "Normalform" @@ -201,13 +225,13 @@ normalformBinder sourceType targetType = Coq.Generalized Coq.Implicit $ Coq.app (Coq.Qualid normalform) $ map Coq.Qualid [shape, pos, sourceType, targetType] --- | The Coq identifier for an implicit argument. -implicitArg :: Coq.Term -implicitArg = Coq.Underscore +-- | The Coq identifier of the @Normalform@ class function. +nf' :: Coq.Qualid +nf' = Coq.bare "nf'" --- | The Coq Identifier for the @share@ operator. -share :: Coq.Qualid -share = Coq.bare "share" +-- | The Coq identifier of the function @nf@. +nf :: Coq.Qualid +nf = Coq.bare "nf" ------------------------------------------------------------------------------- -- Effect selection -- @@ -282,7 +306,11 @@ reservedIdents , strategy , strategyArg , shareableArgs + , shareArgs , normalform + , nf' + , nf , share + , cbneed ] ++ map fst freeArgs diff --git a/src/lib/FreeC/Backend/Coq/Converter/Free.hs b/src/lib/FreeC/Backend/Coq/Converter/Free.hs index c482e4f9..163a7ade 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/Free.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/Free.hs @@ -48,7 +48,7 @@ genericApply' -> [Coq.Term] -- ^ The implicit type class instances to pass to the callee. -> [Coq.Term] -- ^ Implicit arguments to pass explicitly to the callee. -> [Coq.Term] -- ^ The implicit type class arguments that are dependent on - -- the implicit argumnets. + -- the implicit arguments. -> [Coq.Term] -- ^ The actual arguments of the callee. -> Coq.Term genericApply' func explicitEffectArgs implicitEffectArgs implicitArgs diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index b38be49f..497064de 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -390,26 +390,26 @@ convertDataDecl (IR.TypeSynDecl _ _ _ _) -- Instance Generation -- ------------------------------------------------------------------------------- -- | Builds instances for all supported typeclasses. --- Currently, only a @Normalform@ instance is generated. +-- Currently, @Normalform@ and @ShareableArgs@ instances are generated. -- -- Suppose we have a type --- > data T a1 ... an = C1 a11 ... a1m1 | ... | Ck ak1 ... akmk. +-- > data T α₁ … αₙ = C₁ τ₍₁,₁₎ … τ₍₁,ₘ₁₎ | … | Cₖ τ₍ₖ,₁₎ … τ₍ₖ,ₘₖ₎. -- We wish to generate an instance of class @C@ providing the function --- @f : T a1 ... an -> B@, where @B@ is a type. +-- @f : T α₁ … αₙ -> τ@, where @τ@ is a type. -- For example, for the @Normalform@ class, @f@ would be --- > nf' : T a1 ... an -> Free Shape Pos (T a1 ... an). +-- > nf' : T α₁ … αₙ -> Free Shape Pos (T α₁ … αₙ). -- -- The generated function has the following basic structure: -- --- > f'T < class-specific binders > (x : T a1 ... an) : B +-- > f'T < class-specific binders > (x : T α₁ … αₙ) : B -- > := match x with --- > | C1 fx11 ... fx1m1 => < buildValue x [fx11, ..., fx1m1] > --- > | ... --- > | Ck fxk1 ... fxkmk => < buildValue x [fxk1, ..., fxkmk] > +-- > | C₁ fx₍₁,₁₎ … fx₍₁,ₘ₁₎ => < buildValue x [fx₍₁,₁₎, …, fx₍₁,ₘ₁₎ > +-- > | … +-- > | Cₖ fx₍ₖ,₁₎ … fx₍ₖ,ₘₖ₎ => < buildValue x [fx₍ₖ,₁₎, …, fxk₍ₖ,ₘₖ₎] > -- > end. -- --- @buildValue x [fxi1, ..., fximi]@ represents class-specific code that --- actually constructs a value of type @B@ when given @x@ and the +-- @buildValue x [fx₍ᵢ,₁₎, …, fx₍ᵢ,ₘᵢ₎]@ represents class-specific code that +-- actually constructs a value of type @τ@ when given @x@ and the -- constructor's parameters as arguments. -- -- For example, for a @Normalform@ instance of a type @@ -440,8 +440,8 @@ convertDataDecl (IR.TypeSynDecl _ _ _ _) -- signature of the function. -- However, this is not possible for (indirectly) recursive arguments. -- --- A directly recursive argument has the type @T t1 ... tn@, where @ti@ are --- type expressions (not necessarily type variables). We assume that @ti'@ +-- A directly recursive argument has the type @T τ₁ … τₙ@, where @τᵢ@ is a +-- type expressions (not necessarily type variables). We assume that @τᵢ'@ -- does not contain @T@ for any @i@, as this would constitute a non-positive -- occurrence of @T@ and make @T@ invalid in Coq. -- For these arguments, instead of the function @f@ we call @fT@ recursively. @@ -452,90 +452,101 @@ convertDataDecl (IR.TypeSynDecl _ _ _ _) -- (as that would generally require a @C@ instance of @T@) nor can we use -- @fT@. -- --- The problem is solved by introducing a local function fT' for every type +-- The problem is solved by introducing a local function @fT'@ for every type -- @T'@ that contains @T@ that inlines the definition of a @T'@ instance of --- @C@, and call this functions for arguments of type @T'@. +-- @C@, and call this function for arguments of type @T'@. -- These local functions are as polymorphic as possible to reduce the number -- of local functions we need. -- -- For example, if we want to generate an instance for the Haskell type --- @data Forest a = AForest [Forest a] --- | IntForest [Forest Int] --- | BoolForest [ForestBool]@, --- only one local function is needed. --- @fListForest_ : List Shape Pos (Forest Shape Pos a) --- -> Free Shape Pos (List Identity.Shape Identity.Pos --- (Forest Identity.Shape Identity.Pos b))@ -- --- To generate these local function, for every type expression @aij@ in the +-- > data Forest a = AForest [Forest a] +-- > | IntForest [Forest Int] +-- > | BoolForest [Forest Bool] +-- +-- only one local function is needed. In the case of @Normalform@, the local +-- function would look as follows. +-- +-- > nf'ListForest_ {a b : Type} `{Normalform Shape Pos a b} +-- > : List Shape Pos (Forest Shape Pos a) +-- > -> Free Shape Pos (List Identity.Shape Identity.Pos +-- > (Forest Identity.Shape Identity.Pos b)) +-- +-- To generate these local functions, for every type expression @τ₍ᵢ,ⱼ₎@ in the -- constructors of @T@, we collect all types that contain the original type -- @T@. --- More specifically, a type expression @T' t1 ... tm@ is collected if --- @ti = T t1' ... tn'@ for some type expressions @t1', ..., tn'@, or if @ti@ +-- More specifically, a type expression @T' τ₁ … τₙ@ is collected if +-- @τᵢ = T τ₁' … τₙ'@ for some type expressions @τ₁, …, τₙ@, or if @τᵢ@ -- is collected for some @i@. -- During this process, any type expression that does not contain @T@ is --- replaced by a placeholder variable "_". +-- replaced by a placeholder variable @_@. -- -- We keep track of which types correspond to which function with a map. -- --- The generated functions @fT1, ..., fTn@ for @n@ mutually recursive types --- @T1, ... Tn@ are a set of @n@ @Fixpoint@ definitions linked with @with@. +-- The generated functions @fT₁, …, fTₙ@ for @n@ mutually recursive types +-- @T₁, … Tₙ@ are a set of @n@ @Fixpoint@ definitions linked with @with@. -- Indirectly recursive types and local functions based on them are computed -- for each type. -- In this case, a type @T'@ is considered indirectly recursive if it --- contains any of the types @T1, ..., Tn@. --- Arguments of type @Ti@ can be treated like directly recursive arguments. +-- contains any of the types @T₁, …, Tₙ@. +-- Arguments of type @Tᵢ@ can be treated like directly recursive arguments. generateTypeclassInstances :: [IR.TypeDecl] -> Converter [Coq.Sentence] generateTypeclassInstances dataDecls = do -- The types of the data declaration's constructors' arguments. let argTypes = map (concatMap IR.conDeclFields . IR.dataDeclCons) dataDecls -- The same types where all type synonyms are expanded. - argTypesExpanded - <- mapM (mapM expandAllTypeSynonyms) argTypes -- :: [[IR.Type]] + argTypesExpanded <- mapM (mapM expandAllTypeSynonyms) argTypes -- A list where all fully-applied type constructors that do not contain one of the types -- for which we are defining instances and all type variables are replaced with -- the same type variable (an underscore). The list is reversed so its entries are -- in topological order. let reducedTypes = map (nub . reverse . concatMap collectSubTypes) argTypesExpanded - -- Like reducedTypes, but with all occurrences of the types for which we are defining + -- Like 'reducedTypes', but with all occurrences of the types for which we are defining -- instances and all type variables removed from the list. -- This leaves exactly the types with indirect recursion, with all non-recursive -- components replaced by underscores. let recTypeList = map (filter (\t -> not (t `elem` declTypes || IR.isTypeVar t))) reducedTypes - -- Construct Normalform instances. - nfInstances <- buildInstances recTypeList normalformFuncName - normalformClassName nfBindersAndReturnType buildNormalformValue - -- Construct ShareableArgs instances. - shareableArgsInstances <- buildInstances recTypeList shareableArgsFuncName - shareableArgsClassName shareArgsBindersAndReturnType buildShareArgsValue + -- Construct @Normalform@ instances. + nfInstances <- buildInstances recTypeList + (fromJust $ Coq.unpackQualid Coq.Base.nf') + (fromJust $ Coq.unpackQualid Coq.Base.normalform) nfBindersAndReturnType + buildNormalformValue + -- Construct @ShareableArgs@ instances. + shareableArgsInstances <- buildInstances recTypeList + (fromJust $ Coq.unpackQualid Coq.Base.shareArgs) + (fromJust $ Coq.unpackQualid Coq.Base.shareableArgs) + shareArgsBindersAndReturnType buildShareArgsValue return (nfInstances ++ shareableArgsInstances) where - -- The (mutually recursive) data types for which we are defining - -- instances, converted to types. + -- | The (mutually recursive) data types for which we are defining + -- instances, converted to types. All type variable are converted + -- to underscores. declTypes :: [IR.Type] - declTypes = map dataDeclToType dataDecls + declTypes = [IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) + (replicate (length (IR.typeDeclArgs dataDecl)) placeholderVar) + | dataDecl <- dataDecls + ] - -- The names of the constructors of the data types for which + -- The names of the type constructors of the data types for which -- we are defining instances. - conNames :: [IR.TypeConName] - conNames = map IR.typeDeclQName dataDecls + typeConNames :: [IR.TypeConName] + typeConNames = map IR.typeDeclQName dataDecls -- | Constructs instances of a typeclass for a set of mutually recursive -- types. The typeclass is specified by the arguments. buildInstances - :: - -- For each data declaration, this list contains the occurrences of + :: [[IR.Type]] + -- ^ For each data declaration, this list contains the occurrences of -- indirect recursion in the constructors of that data declaration. - [[IR.Type]] - -> String -- The name of the class function. - -> String -- The name of the typeclass. - -> (IR.Type -- The type for which the instance is being defined. - -> Coq.Qualid -- The name of a variable of that type. + -> String -- ^ The name of the class function. + -> String -- ^ The name of the typeclass. + -> (IR.Type -- ^ The type for which the instance is being defined. + -> Coq.Qualid -- ^ The name of a variable of that type. -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term)) - -> (TypeMap -- A mapping from types to function names. - -> Coq.Qualid -- The name of a constructor. + -> (TypeMap -- ^ A mapping from types to function names. + -> Coq.Qualid -- ^ The name of a constructor. -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term) -> Converter [Coq.Sentence] @@ -560,10 +571,12 @@ generateTypeclassInstances dataDecls = do where -- Constructs the class function and class instance for a single type. buildFixBodyAndInstance - :: - -- A map to map occurrences of the top-level types to recursive - -- function calls. - TypeMap -> IR.Type -> [IR.Type] -> Converter (Coq.FixBody, Coq.Sentence) + :: TypeMap + -- ^ A map to map occurrences of the top-level types to recursive + -- function calls. + -> IR.Type -- ^ The type for which we are defining an instance. + -> [IR.Type] -- ^ The list of indirectly recursive types. + -> Converter (Coq.FixBody, Coq.Sentence) buildFixBodyAndInstance topLevelMap t recTypes = do -- Locally visible definitions are defined in a local environment. (fixBody, typeLevelMap, binders, instanceRetType) <- localEnv $ do @@ -589,9 +602,12 @@ generateTypeclassInstances dataDecls = do -- | Builds an instance for a specific type and typeclass. buildInstance - :: - -- A mapping from (indirectly) recursive types to function names. - TypeMap -> IR.Type -> [Coq.Binder] -> Coq.Term -> Converter Coq.Sentence + :: TypeMap + -- ^ A mapping from (in)directly recursive types to function names. + -> IR.Type -- ^ The type for which we are defining an instance. + -> [Coq.Binder] -- ^ The binders for the type class instance. + -> Coq.Term -- ^ The type of the instance. + -> Converter Coq.Sentence buildInstance m t binders retType = do -- Define the class function as the function to which the current type -- is mapped. @@ -606,15 +622,13 @@ generateTypeclassInstances dataDecls = do -- | Generates the implementation of the body of a class function for the -- given type. makeFixBody - :: - -- A mapping from (indirectly or directly) recursive types to the name - -- of the function that handles arguments of those types. - TypeMap - -> Coq.Qualid - -> IR.Type - -> [Coq.Binder] - -> Coq.Term - -> [IR.Type] + :: TypeMap + -- ^ A mapping from (in)directly recursive types to function names. + -> Coq.Qualid -- ^ The name of the argument of type @t@. + -> IR.Type -- ^ The type for which we are defining an instance. + -> [Coq.Binder] -- ^ The binders for the class function. + -> Coq.Term -- ^ The return type of the class function. + -> [IR.Type] -- ^ The list of indirectly recursive types. -> Converter Coq.FixBody makeFixBody m varName t binders retType recTypes = do rhs <- generateBody m varName t recTypes @@ -626,7 +640,12 @@ generateTypeclassInstances dataDecls = do -- | Creates the function body for a class function by creating local -- functions for all indirectly recursive types. generateBody - :: TypeMap -> Coq.Qualid -> IR.Type -> [IR.Type] -> Converter Coq.Term + :: TypeMap + -- ^ A mapping from (in)directly recursive types to function names. + -> Coq.Qualid -- ^ The name of the argument of type @t@. + -> IR.Type -- ^ The type for which we are defining an instance. + -> [IR.Type] -- ^ The list of indirectly recursive types. + -> Converter Coq.Term -- If there are no indirectly recursive types, match on the constructors of -- the original type. @@ -675,57 +694,41 @@ generateTypeclassInstances dataDecls = do -- Find out the type of each constructor argument by unifying its return -- type with the given type expression and applying the resulting -- substitution to each constructor argument's type. - -- Then convert all irrelevant components into underscores again so the + -- Then convert all irrelevant components to underscores again so the -- type can be looked up in the type map. expandedArgTypes <- mapM expandAllTypeSynonyms (entryArgTypes conEntry) let modArgTypes = map (stripType . applySubst subst) expandedArgTypes let lhs = Coq.ArgsPat conIdent (map Coq.QualidPat conArgIdents) -- Build the right-hand side of the equation by applying the - -- class-specific function buildValue. + -- class-specific function @buildValue@. rhs <- buildValue m conIdent (zip modArgTypes conArgIdents) return $ Coq.equation lhs rhs ------------------------------------------------------------------------------- - -- Typeclass-specific Functions -- + -- Functions to produce @Normalform@ instances -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- - -- Functions to produce Normalform instances -- - ------------------------------------------------------------------------------- - -- | The name of the Normalform class. - normalformClassName :: String - normalformClassName = "Normalform" - - -- | The name of the Normalform class function. - normalformFuncName :: String - normalformFuncName = "nf'" - - -- | The function nf. - normalformFunc :: Coq.Term - normalformFunc = Coq.Qualid (Coq.bare "nf") - - -- | The binders and return types for the Normalform class function and instance. + -- | The binders and return types for the @Normalform@ class function and instance. nfBindersAndReturnType - :: - -- The type @t@ for which we are defining an instance. - IR.Type - -> Coq.Qualid + :: IR.Type + -- ^ The type @t@ for which we are defining an instance. + -> Coq.Qualid -- ^ The name of the argument of type @t@. -> Converter - ( [Coq.Binder] -- Type variable binders and Normalform constraints. + ( [Coq.Binder] -- Type variable binders and @Normalform@ constraints. , Coq.Binder -- Binder for the argument of type @t@. , Coq.Term -- Return type of @nf'@. - , Coq.Term -- Return type of the Normalform instance. + , Coq.Term -- Return type of the @Normalform@ instance. ) nfBindersAndReturnType t varName = do -- For each type variable in the type, generate two type variables. -- One represents the type's variable itself, the other the result -- type of the normalization. - -- The type is transformed to a Coq type twice, once with Shape and - -- Pos as arguments for the original type, once with Identity.Shape - -- and Identity.Pos as arguments for the normalized result type. + -- The type is transformed to a Coq type twice, once with @Shape@ and + -- @Pos@ as arguments for the original type, once with @Identity.Shape@ + -- and @Identity.Pos@ as arguments for the normalized result type. (sourceType, sourceVars) <- toCoqType "a" shapeAndPos t (targetType, targetVars) <- toCoqType "b" idShapeAndPos t - -- For each type variable ai, build a constraint - -- `{Normalform Shape Pos ai bi}. + -- For each type variable @ai@, build a constraint + -- @`{Normalform Shape Pos ai bi}@. let constraints = zipWith Coq.Base.normalformBinder sourceVars targetVars let varBinder = [typeVarBinder (sourceVars ++ targetVars) | not (null sourceVars)] @@ -733,7 +736,7 @@ generateTypeclassInstances dataDecls = do -- Create an explicit argument binder for the value to be normalized. let topLevelVarBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit varName sourceType - let instanceRetType = Coq.app (Coq.Qualid (Coq.bare normalformClassName)) + let instanceRetType = Coq.app (Coq.Qualid (Coq.Base.normalform)) (shapeAndPos ++ [sourceType, targetType]) let funcRetType = applyFree targetType return (binders, topLevelVarBinder, funcRetType, instanceRetType) @@ -741,9 +744,12 @@ generateTypeclassInstances dataDecls = do -- | Builds a normalized @Free@ value for the given constructor -- and constructor arguments. buildNormalformValue - :: - -- A map to associate types with the appropriate functions to call. - TypeMap -> Coq.Qualid -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term + :: TypeMap + -- ^ A map to associate types with the appropriate functions to call. + -> Coq.Qualid -- ^ The data constructor used to build a value. + -> [(IR.Type, Coq.Qualid)] + -- ^ The types and names of the constructor's arguments. + -> Converter Coq.Term buildNormalformValue nameMap consName = buildNormalformValue' [] where -- | Like 'buildNormalformValue', but with an additional parameter to accumulate @@ -781,28 +787,24 @@ generateTypeclassInstances dataDecls = do nx <- freshCoqQualid ("n" ++ freshArgPrefix) rhs <- buildNormalformValue' (nx : boundVars) consVars let c = Coq.fun [nx] [Nothing] rhs - return $ applyBind (Coq.app normalformFunc [Coq.Qualid varName]) c + return + $ applyBind (Coq.app (Coq.Qualid Coq.Base.nf) [Coq.Qualid varName]) + c ------------------------------------------------------------------------------- - -- Functions to produce ShareableArgs instances -- + -- Functions to produce @ShareableArgs@ instances -- ------------------------------------------------------------------------------- - -- | The name of the Normalform class. - shareableArgsClassName :: String - shareableArgsClassName = "ShareableArgs" - - -- | The name of the Normalform class function. - shareableArgsFuncName :: String - shareableArgsFuncName = "shareArgs" - - -- | The name of the cbneed operator. - cbneedFunc :: Coq.Term - cbneedFunc = Coq.Qualid (Coq.bare "cbneed") - - -- | The binders and return types for the ShareableArgs class function and instance. + -- | The binders and return types for the @ShareableArgs@ class function and instance. shareArgsBindersAndReturnType :: IR.Type - -> Coq.Qualid - -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term) + -- ^ The type @t@ for which we are defining an instance. + -> Coq.Qualid -- ^ The name of the argument of type @t@. + -> Converter + ( [Coq.Binder] -- Type variable binders and @ShareableArgs@ constraints. + , Coq.Binder -- Binder for the argument of type @t@. + , Coq.Term -- Return type of @shareArgs@. + , Coq.Term -- Return type of the @ShareableArgs@ instance. + ) shareArgsBindersAndReturnType t varName = do (coqType, vars) <- toCoqType "a" shapeAndPos t let constraints @@ -819,7 +821,12 @@ generateTypeclassInstances dataDecls = do -- | Shares all arguments of the given constructor and reconstructs the -- value with the shared components. buildShareArgsValue - :: TypeMap -> Coq.Qualid -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term + :: TypeMap + -- ^ A map to associate types with the appropriate functions to call. + -> Coq.Qualid -- ^ The data constructor used to build a value. + -> [(IR.Type, Coq.Qualid)] + -- ^ The types and names of the constructor's arguments. + -> Converter Coq.Term buildShareArgsValue nameMap consName = buildShareArgsValue' [] where buildShareArgsValue' @@ -833,16 +840,16 @@ generateTypeclassInstances dataDecls = do Just funcName -> do return $ applyBind - (Coq.app cbneedFunc + (Coq.app (Coq.Qualid Coq.Base.cbneed) (shapeAndPos ++ [Coq.Qualid funcName, Coq.Qualid varName])) (Coq.fun [sx] [Nothing] rhs) Nothing -> do return - $ applyBind (Coq.app cbneedFunc - (shapeAndPos - ++ [ Coq.Qualid (Coq.bare shareableArgsFuncName) - , Coq.Qualid varName - ])) (Coq.fun [sx] [Nothing] rhs) + $ applyBind + (Coq.app (Coq.Qualid Coq.Base.cbneed) + (shapeAndPos + ++ [Coq.Qualid (Coq.Base.shareArgs), Coq.Qualid varName])) + (Coq.fun [sx] [Nothing] rhs) ------------------------------------------------------------------------------- -- Helper functions -- @@ -852,7 +859,7 @@ generateTypeclassInstances dataDecls = do nameFunctionsAndInsert :: String -> TypeMap -> [IR.Type] -> Converter TypeMap nameFunctionsAndInsert prefix = foldM (nameFunctionAndInsert prefix) - -- | Like `nameFunctionsAndInsert`, but for a single type. + -- | Like 'nameFunctionsAndInsert', but for a single type. nameFunctionAndInsert :: String -> TypeMap -> IR.Type -> Converter TypeMap nameFunctionAndInsert prefix m t = do name <- nameFunction prefix t @@ -866,17 +873,17 @@ generateTypeclassInstances dataDecls = do freshCoqIdent (prefix ++ prettyType) -- | A type variable that represents irrelevant parts of a type expression. - -- Represented by an underscore. + -- Represented by an underscore. placeholderVar :: IR.Type placeholderVar = IR.TypeVar NoSrcSpan "_" - -- | Collects all fully-applied type constructors - -- of arity at least 1 (including their arguments) that occur in the given - -- type. All arguments that do not contain occurrences of the types for - -- which we are defining an instance are replaced by the type variable "_". + -- | Collects all fully-applied type constructors of arity at least 1 + -- (including their arguments) that occur in the given type. All arguments + -- that do not contain occurrences of the types for which we are defining + -- an instance are replaced by the type variable @_@. -- The resulting list contains (in reverse topological order) exactly all -- types for which we must define a separate function in the instance - -- definition, where all occurrences of "_" represent the polymorphic + -- definition, where all occurrences of @_@ represent the polymorphic -- components of the function. collectSubTypes :: IR.Type -> [IR.Type] collectSubTypes = collectFullyAppliedTypes True @@ -902,7 +909,7 @@ generateTypeclassInstances dataDecls = do -- | Returns the same type with all type expressions that do not contain one -- of the type constructors for which we are defining instances replaced - -- by the type variable "_". + -- with the type variable @_@. stripType :: IR.Type -> IR.Type stripType t = stripType' t False where @@ -910,24 +917,24 @@ generateTypeclassInstances dataDecls = do -- occurrence of a relevant type was found in an argument of a type -- application. -- This is necessary so that, for example, @Pair Bool t@ is not - -- translated to @_ t@, but to @Pair _ t@. + -- transformed to @_ t@, but to @Pair _ t@. stripType' :: IR.Type -> Bool -> IR.Type - - -- stripType' (IR.TypeCon _ conName) flag - | flag || conName `elem` conNames = IR.TypeCon NoSrcSpan conName + | flag || conName `elem` typeConNames = IR.TypeCon NoSrcSpan conName | otherwise = placeholderVar - -- For a type application, check if a relevant type occurs in @r@. + -- For a type application, check if a relevant type occurs in its + -- right-hand side. stripType' (IR.TypeApp _ l r) flag = case stripType' r False of - -- If not, check if a relevant type occurs in @l@, and otherwise - -- replace the whole expression with an underscore. + -- If not, check if a relevant type occurs in its left-hand side, + -- otherwise replace the whole expression with an underscore. r'@(IR.TypeVar _ _) -> case stripType' l flag of IR.TypeVar _ _ -> placeholderVar l' -> IR.TypeApp NoSrcSpan l' r' - -- If a relevant type does occur in @r@, the type application must - -- be preserved, so only its arguments are stripped.´ + -- If a relevant type does occur in the right-hand side, + -- the type application must be preserved, so only its arguments are + -- stripped. r' -> IR.TypeApp NoSrcSpan (stripType' l True) r' - -- Type variables and function types are not relevant and are replaced by "_". + -- Type variables and function types are not relevant and are replaced by @_@. stripType' _ _ = placeholderVar -- | Like @showPretty@, but uses the Coq identifiers of the type and its components. @@ -947,12 +954,6 @@ generateTypeclassInstances dataDecls = do showPrettyType (IR.FuncType _ _ _) = error "Function types should have been eliminated." - -- | Converts a data declaration to a type by applying its constructor to the - -- correct number of variables, denoted by underscores. - dataDeclToType :: IR.TypeDecl -> IR.Type - dataDeclToType dataDecl = IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) - (replicate (length (IR.typeDeclArgs dataDecl)) placeholderVar) - -- | Replaces all variables in a type with fresh variables. insertFreshVariables :: IR.Type -> Converter IR.Type insertFreshVariables (IR.TypeVar srcSpan _) = do @@ -966,29 +967,31 @@ generateTypeclassInstances dataDecls = do insertFreshVariables t = return t -- | Binders for (implicit) Shape and Pos arguments. - -- > freeArgsBinders = [ {Shape : Type}, {Pos : Shape -> Type} ] + -- + -- > freeArgsBinders = [ {Shape : Type}, {Pos : Shape -> Type} ] freeArgsBinders :: [Coq.Binder] freeArgsBinders = genericArgDecls Coq.Implicit -- | Shortcut for the construction of an implicit binder for type variables. - -- > typeVarBinder [a1, ..., an] = {a1 ... an : Type} + -- + -- > typeVarBinder [α₁, …, an] = {α₁ …αₙ : Type} typeVarBinder :: [Coq.Qualid] -> Coq.Binder typeVarBinder typeVars = Coq.typedBinder Coq.Ungeneralizable Coq.Implicit typeVars Coq.sortType - -- | Shortcut for the application of >>=. + -- | Shortcut for the application of @>>=@. applyBind :: Coq.Term -> Coq.Term -> Coq.Term applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [mx, f] - -- | Given an A, returns Free Shape Pos A + -- | Given an @A@, returns @Free Shape Pos A@. applyFree :: Coq.Term -> Coq.Term - applyFree a = Coq.app (Coq.Qualid Coq.Base.free) (shapeAndPos ++ [a]) + applyFree a = genericApply Coq.Base.free [] [] [a] - -- | Shape and Pos arguments as Coq terms. + -- | @Shape@ and @Pos@ arguments as Coq terms. shapeAndPos :: [Coq.Term] shapeAndPos = [Coq.Qualid Coq.Base.shape, Coq.Qualid Coq.Base.pos] - -- | The shape and position function arguments for the Identity monad + -- | The shape and position function arguments for the identity monad -- as a Coq term. idShapeAndPos :: [Coq.Term] idShapeAndPos = map Coq.Qualid @@ -997,13 +1000,14 @@ generateTypeclassInstances dataDecls = do ] -- | Converts a type into a Coq type (a term) with the specified - -- additional arguments (for example Shape and Pos) and fresh Coq + -- additional arguments (for example @Shape@ and @Pos@) and fresh Coq -- identifiers for all underscores. -- Returns a pair of the result term and a list of the fresh variables. - toCoqType :: String -- The prefix of the fresh variables. - -> [Coq.Term] -- A list of additional arguments, e.g. Shape and Pos. - -> IR.Type -- The type to convert. - -> Converter (Coq.Term, [Coq.Qualid]) + toCoqType + :: String -- ^ The prefix of the fresh variables. + -> [Coq.Term] -- ^ A list of additional arguments, e.g. Shape and Pos. + -> IR.Type -- ^ The type to convert. + -> Converter (Coq.Term, [Coq.Qualid]) -- A type variable is translated into a fresh type variable. toCoqType varPrefix _ (IR.TypeVar _ _) = do From 030a2557673f627469be58fba8cdde4114736168 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 20 Sep 2020 12:27:44 +0200 Subject: [PATCH 077/120] Fix HLint and Haddock errors #150 --- src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 497064de..1d909210 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -542,13 +542,13 @@ generateTypeclassInstances dataDecls = do -- indirect recursion in the constructors of that data declaration. -> String -- ^ The name of the class function. -> String -- ^ The name of the typeclass. - -> (IR.Type -- ^ The type for which the instance is being defined. - -> Coq.Qualid -- ^ The name of a variable of that type. + -> (IR.Type + -> Coq.Qualid -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term)) - -> (TypeMap -- ^ A mapping from types to function names. - -> Coq.Qualid -- ^ The name of a constructor. - -> [(IR.Type, Coq.Qualid)] - -> Converter Coq.Term) + -- ^ A function to get class-specific binders and return types. + -> (TypeMap -> Coq.Qualid -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term) + -- ^ A function to compute a class-specific value given a data constructor + -- with arguments. -> Converter [Coq.Sentence] buildInstances recTypeList functionPrefix className getBindersAndReturnTypes buildValue = do @@ -736,7 +736,7 @@ generateTypeclassInstances dataDecls = do -- Create an explicit argument binder for the value to be normalized. let topLevelVarBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit varName sourceType - let instanceRetType = Coq.app (Coq.Qualid (Coq.Base.normalform)) + let instanceRetType = Coq.app (Coq.Qualid Coq.Base.normalform) (shapeAndPos ++ [sourceType, targetType]) let funcRetType = applyFree targetType return (binders, topLevelVarBinder, funcRetType, instanceRetType) @@ -848,7 +848,7 @@ generateTypeclassInstances dataDecls = do $ applyBind (Coq.app (Coq.Qualid Coq.Base.cbneed) (shapeAndPos - ++ [Coq.Qualid (Coq.Base.shareArgs), Coq.Qualid varName])) + ++ [Coq.Qualid Coq.Base.shareArgs, Coq.Qualid varName])) (Coq.fun [sx] [Nothing] rhs) ------------------------------------------------------------------------------- From 9103c13366e9e5476dbd014724712440f34ced4e Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 20 Sep 2020 13:09:50 +0200 Subject: [PATCH 078/120] Move instance and induction scheme generation into separate modules #150 --- free-compiler.cabal | 2 + .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 802 +----------------- .../Coq/Converter/TypeDecl/InductionScheme.hs | 96 +++ .../Converter/TypeDecl/TypeclassInstances.hs | 677 +++++++++++++++ 4 files changed, 816 insertions(+), 761 deletions(-) create mode 100644 src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs create mode 100644 src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs diff --git a/free-compiler.cabal b/free-compiler.cabal index 533050c0..ce22c626 100644 --- a/free-compiler.cabal +++ b/free-compiler.cabal @@ -114,6 +114,8 @@ library freec-internal , FreeC.Backend.Coq.Converter.Module , FreeC.Backend.Coq.Converter.Type , FreeC.Backend.Coq.Converter.TypeDecl + , FreeC.Backend.Coq.Converter.TypeDecl.InductionScheme + , FreeC.Backend.Coq.Converter.TypeDecl.TypeclassInstances , FreeC.Backend.Coq.Keywords , FreeC.Backend.Coq.Pretty , FreeC.Backend.Coq.Syntax diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 1d909210..9f2f3891 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -14,33 +14,33 @@ module FreeC.Backend.Coq.Converter.TypeDecl ) where import Control.Monad - ( foldM, mapAndUnzipM, replicateM ) -import Control.Monad.Extra ( concatMapM ) -import Data.List ( nub, partition ) -import Data.List.Extra ( concatUnzip ) -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map.Strict as Map -import Data.Maybe ( catMaybes, fromJust ) -import qualified Data.Set as Set -import qualified Data.Text as Text - -import qualified FreeC.Backend.Coq.Base as Coq.Base + ( mapAndUnzipM ) +import Control.Monad.Extra + ( concatMapM ) +import Data.List + ( partition ) +import Data.List.Extra + ( concatUnzip ) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe + ( catMaybes, fromJust ) +import qualified Data.Set as Set + +import qualified FreeC.Backend.Coq.Base as Coq.Base import FreeC.Backend.Coq.Converter.Arg import FreeC.Backend.Coq.Converter.Free import FreeC.Backend.Coq.Converter.Type -import qualified FreeC.Backend.Coq.Syntax as Coq +import FreeC.Backend.Coq.Converter.TypeDecl.InductionScheme +import FreeC.Backend.Coq.Converter.TypeDecl.TypeclassInstances +import qualified FreeC.Backend.Coq.Syntax as Coq import FreeC.Environment -import FreeC.Environment.Entry import FreeC.Environment.Fresh - ( freshArgPrefix, freshCoqIdent, freshCoqQualid, freshHaskellIdent ) -import FreeC.Environment.LookupOrFail -import FreeC.Environment.Renamer ( renameAndDefineTypeVar ) + ( freshArgPrefix, freshCoqIdent ) +import FreeC.Environment.Renamer + ( renameAndDefineTypeVar ) import FreeC.IR.DependencyGraph -import FreeC.IR.SrcSpan ( SrcSpan(NoSrcSpan) ) -import FreeC.IR.Subst -import qualified FreeC.IR.Syntax as IR +import qualified FreeC.IR.Syntax as IR import FreeC.IR.TypeSynExpansion -import FreeC.IR.Unification import FreeC.Monad.Converter import FreeC.Monad.Reporter import FreeC.Pretty @@ -116,9 +116,6 @@ convertTypeSynDecl (IR.DataDecl _ _ _ _) ------------------------------------------------------------------------------- -- Data type declarations -- ------------------------------------------------------------------------------- --- | Type synonym for a map mapping types to function names. -type TypeMap = Map.Map IR.Type Coq.Qualid - -- | Converts multiple (mutually recursive) Haskell data type declaration -- declarations. -- @@ -155,26 +152,27 @@ convertDataDecls dataDecls = do -- not visible outside of this function. convertDataDecl :: IR.TypeDecl -> Converter (Coq.IndBody, ([Coq.Sentence], [Coq.Sentence])) -convertDataDecl (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do - (body, argumentsSentences) <- generateBodyAndArguments - (smartConDecls, qualSmartConDecls) - <- concatUnzip <$> mapM generateSmartConDecl conDecls - inductionScheme <- generateInductionScheme - return ( body - , ( Coq.commentedSentences - ("Arguments sentences for " ++ showPretty (IR.toUnQual name)) - argumentsSentences - ++ Coq.commentedSentences - ("Induction scheme for " ++ showPretty (IR.toUnQual name)) - inductionScheme - ++ Coq.commentedSentences - ("Smart constructors for " ++ showPretty (IR.toUnQual name)) - smartConDecls - , Coq.commentedSentences ("Qualified smart constructors for " - ++ showPretty (IR.toUnQual name)) - qualSmartConDecls - ) - ) +convertDataDecl dataDecl + @(IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do + (body, argumentsSentences) <- generateBodyAndArguments + (smartConDecls, qualSmartConDecls) + <- concatUnzip <$> mapM generateSmartConDecl conDecls + inductionScheme <- generateInductionScheme dataDecl + return ( body + , ( Coq.commentedSentences + ("Arguments sentences for " ++ showPretty (IR.toUnQual name)) + argumentsSentences + ++ Coq.commentedSentences + ("Induction scheme for " ++ showPretty (IR.toUnQual name)) + inductionScheme + ++ Coq.commentedSentences + ("Smart constructors for " ++ showPretty (IR.toUnQual name)) + smartConDecls + , Coq.commentedSentences ("Qualified smart constructors for " + ++ showPretty (IR.toUnQual name)) + qualSmartConDecls + ) + ) where -- | Generates the body of the @Inductive@ sentence and the @Arguments@ -- sentences for the constructors but not the smart constructors @@ -309,724 +307,6 @@ convertDataDecl (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do , Coq.sModLevel 10 , Coq.sModIdentLevel (NonEmpty.fromList expArgIdents) (Just 9) ] - - -- | Generates an induction scheme for the data type. - generateInductionScheme :: Converter [Coq.Sentence] - generateInductionScheme = localEnv $ do - Just tIdent <- inEnv $ lookupIdent IR.TypeScope name - -- Create variables and binders. - let generateArg :: Coq.Term -> Converter (Coq.Qualid, Coq.Binder) - generateArg argType = do - ident <- freshCoqQualid freshArgPrefix - return - $ ( ident - , Coq.typedBinder Coq.Ungeneralizable Coq.Explicit [ident] argType - ) - (tvarIdents, tvarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls - (propIdent, propBinder) <- generateArg - (Coq.Arrow (genericApply tIdent [] [] (map Coq.Qualid tvarIdents)) - (Coq.Sort Coq.Prop)) - (_hIdents, hBinders) <- mapAndUnzipM (generateInductionCase propIdent) - conDecls - (valIdent, valBinder) <- generateArg - (genericApply tIdent [] [] (map Coq.Qualid tvarIdents)) - -- Stick everything together. - schemeName <- freshCoqQualid $ fromJust (Coq.unpackQualid tIdent) ++ "_Ind" - hypothesisVar <- freshCoqIdent "H" - let binders = genericArgDecls Coq.Explicit - ++ tvarBinders - ++ [propBinder] - ++ hBinders - term = Coq.Forall (NonEmpty.fromList [valBinder]) - (Coq.app (Coq.Qualid propIdent) [Coq.Qualid valIdent]) - scheme = Coq.Assertion Coq.Definition schemeName binders term - proof = Coq.ProofDefined - (Text.pack - $ " fix " - ++ hypothesisVar - ++ " 1; intro; " - ++ fromJust (Coq.unpackQualid Coq.Base.proveInd) - ++ ".") - return [Coq.AssertionSentence scheme proof] - - -- | Generates an induction case for a given property and constructor. - generateInductionCase - :: Coq.Qualid -> IR.ConDecl -> Converter (Coq.Qualid, Coq.Binder) - generateInductionCase pIdent (IR.ConDecl _ declIdent argTypes) = do - let conName = IR.declIdentName declIdent - Just conIdent <- inEnv $ lookupIdent IR.ValueScope conName - Just conType' <- inEnv $ lookupReturnType IR.ValueScope conName - conType <- convertType' conType' - fConType <- convertType conType' - fArgTypes <- mapM convertType argTypes - (argIdents, argBinders) <- mapAndUnzipM convertAnonymousArg - (map Just argTypes) - let - -- We need an induction hypothesis for every argument that has the same - -- type as the constructor but lifted into the free monad. - addHypotheses' :: [(Coq.Term, Coq.Qualid)] -> Coq.Term -> Coq.Term - addHypotheses' [] = id - addHypotheses' ((argType, argIdent) : args) - | argType == fConType = Coq.Arrow - (genericForFree conType pIdent argIdent) - . addHypotheses' args - addHypotheses' (_ : args) = addHypotheses' args - addHypotheses = addHypotheses' (zip fArgTypes argIdents) - -- Create induction case. - term = addHypotheses - (Coq.app (Coq.Qualid pIdent) - [Coq.app (Coq.Qualid conIdent) (map Coq.Qualid argIdents)]) - indCase = if null argBinders - then term - else Coq.Forall (NonEmpty.fromList argBinders) term - indCaseIdent <- freshCoqQualid freshArgPrefix - indCaseBinder <- generateArgBinder indCaseIdent (Just indCase) - return (indCaseIdent, indCaseBinder) -- Type synonyms are not allowed in this function. convertDataDecl (IR.TypeSynDecl _ _ _ _) = error "convertDataDecl: Type synonym not allowed." - -------------------------------------------------------------------------------- --- Instance Generation -- -------------------------------------------------------------------------------- --- | Builds instances for all supported typeclasses. --- Currently, @Normalform@ and @ShareableArgs@ instances are generated. --- --- Suppose we have a type --- > data T α₁ … αₙ = C₁ τ₍₁,₁₎ … τ₍₁,ₘ₁₎ | … | Cₖ τ₍ₖ,₁₎ … τ₍ₖ,ₘₖ₎. --- We wish to generate an instance of class @C@ providing the function --- @f : T α₁ … αₙ -> τ@, where @τ@ is a type. --- For example, for the @Normalform@ class, @f@ would be --- > nf' : T α₁ … αₙ -> Free Shape Pos (T α₁ … αₙ). --- --- The generated function has the following basic structure: --- --- > f'T < class-specific binders > (x : T α₁ … αₙ) : B --- > := match x with --- > | C₁ fx₍₁,₁₎ … fx₍₁,ₘ₁₎ => < buildValue x [fx₍₁,₁₎, …, fx₍₁,ₘ₁₎ > --- > | … --- > | Cₖ fx₍ₖ,₁₎ … fx₍ₖ,ₘₖ₎ => < buildValue x [fx₍ₖ,₁₎, …, fxk₍ₖ,ₘₖ₎] > --- > end. --- --- @buildValue x [fx₍ᵢ,₁₎, …, fx₍ᵢ,ₘᵢ₎]@ represents class-specific code that --- actually constructs a value of type @τ@ when given @x@ and the --- constructor's parameters as arguments. --- --- For example, for a @Normalform@ instance of a type --- @data List a = Nil | Cons a (List a)@, --- the function would look as follows. --- --- > nf'List_ {Shape : Type} {Pos : Shape -> Type} --- > {a b : Type} `{Normalform Shape Pos a b} --- > (x : List Shape Pos a) --- > : Free Shape Pos (List Identity.Shape Identity.Pos b) --- > := match x with --- > | nil => pure nil --- > | cons fx_0 fx_1 => nf fx_0 >>= fun nx_0 => --- > fx_1 >>= fun x_1 => --- > nf'List x_1 >>= fun nx_1 => --- > pure (cons (pure nx_0) (pure nx_1)) --- > end. --- --- Typically, @buildValue@ will use the class function @f@ on all components, --- then reconstruct the value using the results of those function calls. --- In the example above, we use @nf@ on @fx_0@ of type @a@. @nf fx_0@ means --- the same as @fx_0 >>= fun x_0 => nf' x_0@. --- --- Since we translate types in topological order and @C@ instances exist for --- all previously translated types (and types from the Prelude), we can use --- @f@ on most arguments. --- For all type variables, we introduce class constraints into the type --- signature of the function. --- However, this is not possible for (indirectly) recursive arguments. --- --- A directly recursive argument has the type @T τ₁ … τₙ@, where @τᵢ@ is a --- type expressions (not necessarily type variables). We assume that @τᵢ'@ --- does not contain @T@ for any @i@, as this would constitute a non-positive --- occurrence of @T@ and make @T@ invalid in Coq. --- For these arguments, instead of the function @f@ we call @fT@ recursively. --- --- An indirectly recursive argument is an argument of a type that is not @T@, --- but contains @T@. --- These arguments are problematic because we can neither use @f@ on them --- (as that would generally require a @C@ instance of @T@) nor can we use --- @fT@. --- --- The problem is solved by introducing a local function @fT'@ for every type --- @T'@ that contains @T@ that inlines the definition of a @T'@ instance of --- @C@, and call this function for arguments of type @T'@. --- These local functions are as polymorphic as possible to reduce the number --- of local functions we need. --- --- For example, if we want to generate an instance for the Haskell type --- --- > data Forest a = AForest [Forest a] --- > | IntForest [Forest Int] --- > | BoolForest [Forest Bool] --- --- only one local function is needed. In the case of @Normalform@, the local --- function would look as follows. --- --- > nf'ListForest_ {a b : Type} `{Normalform Shape Pos a b} --- > : List Shape Pos (Forest Shape Pos a) --- > -> Free Shape Pos (List Identity.Shape Identity.Pos --- > (Forest Identity.Shape Identity.Pos b)) --- --- To generate these local functions, for every type expression @τ₍ᵢ,ⱼ₎@ in the --- constructors of @T@, we collect all types that contain the original type --- @T@. --- More specifically, a type expression @T' τ₁ … τₙ@ is collected if --- @τᵢ = T τ₁' … τₙ'@ for some type expressions @τ₁, …, τₙ@, or if @τᵢ@ --- is collected for some @i@. --- During this process, any type expression that does not contain @T@ is --- replaced by a placeholder variable @_@. --- --- We keep track of which types correspond to which function with a map. --- --- The generated functions @fT₁, …, fTₙ@ for @n@ mutually recursive types --- @T₁, … Tₙ@ are a set of @n@ @Fixpoint@ definitions linked with @with@. --- Indirectly recursive types and local functions based on them are computed --- for each type. --- In this case, a type @T'@ is considered indirectly recursive if it --- contains any of the types @T₁, …, Tₙ@. --- Arguments of type @Tᵢ@ can be treated like directly recursive arguments. -generateTypeclassInstances :: [IR.TypeDecl] -> Converter [Coq.Sentence] -generateTypeclassInstances dataDecls = do - -- The types of the data declaration's constructors' arguments. - let argTypes = map (concatMap IR.conDeclFields . IR.dataDeclCons) dataDecls - -- The same types where all type synonyms are expanded. - argTypesExpanded <- mapM (mapM expandAllTypeSynonyms) argTypes - -- A list where all fully-applied type constructors that do not contain one of the types - -- for which we are defining instances and all type variables are replaced with - -- the same type variable (an underscore). The list is reversed so its entries are - -- in topological order. - let reducedTypes = map (nub . reverse . concatMap collectSubTypes) - argTypesExpanded - -- Like 'reducedTypes', but with all occurrences of the types for which we are defining - -- instances and all type variables removed from the list. - -- This leaves exactly the types with indirect recursion, with all non-recursive - -- components replaced by underscores. - let recTypeList = map - (filter (\t -> not (t `elem` declTypes || IR.isTypeVar t))) reducedTypes - -- Construct @Normalform@ instances. - nfInstances <- buildInstances recTypeList - (fromJust $ Coq.unpackQualid Coq.Base.nf') - (fromJust $ Coq.unpackQualid Coq.Base.normalform) nfBindersAndReturnType - buildNormalformValue - -- Construct @ShareableArgs@ instances. - shareableArgsInstances <- buildInstances recTypeList - (fromJust $ Coq.unpackQualid Coq.Base.shareArgs) - (fromJust $ Coq.unpackQualid Coq.Base.shareableArgs) - shareArgsBindersAndReturnType buildShareArgsValue - return (nfInstances ++ shareableArgsInstances) - where - -- | The (mutually recursive) data types for which we are defining - -- instances, converted to types. All type variable are converted - -- to underscores. - declTypes :: [IR.Type] - declTypes = [IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) - (replicate (length (IR.typeDeclArgs dataDecl)) placeholderVar) - | dataDecl <- dataDecls - ] - - -- The names of the type constructors of the data types for which - -- we are defining instances. - typeConNames :: [IR.TypeConName] - typeConNames = map IR.typeDeclQName dataDecls - - -- | Constructs instances of a typeclass for a set of mutually recursive - -- types. The typeclass is specified by the arguments. - buildInstances - :: [[IR.Type]] - -- ^ For each data declaration, this list contains the occurrences of - -- indirect recursion in the constructors of that data declaration. - -> String -- ^ The name of the class function. - -> String -- ^ The name of the typeclass. - -> (IR.Type - -> Coq.Qualid - -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term)) - -- ^ A function to get class-specific binders and return types. - -> (TypeMap -> Coq.Qualid -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term) - -- ^ A function to compute a class-specific value given a data constructor - -- with arguments. - -> Converter [Coq.Sentence] - buildInstances recTypeList functionPrefix className getBindersAndReturnTypes - buildValue = do - -- This map defines the name of the top-level class function for each - -- of the mutually recursive types. - -- It must be defined outside of a local environment to prevent any - -- clashes of the function names with other names. - topLevelMap <- nameFunctionsAndInsert functionPrefix Map.empty declTypes - (fixBodies, instances) <- mapAndUnzipM - (uncurry (buildFixBodyAndInstance topLevelMap)) - (zip declTypes recTypeList) - return - $ Coq.comment (className - ++ " instance" - ++ ['s' | length dataDecls > 1] - ++ " for " - ++ showPretty (map IR.typeDeclName dataDecls)) - : Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) - : instances - where - -- Constructs the class function and class instance for a single type. - buildFixBodyAndInstance - :: TypeMap - -- ^ A map to map occurrences of the top-level types to recursive - -- function calls. - -> IR.Type -- ^ The type for which we are defining an instance. - -> [IR.Type] -- ^ The list of indirectly recursive types. - -> Converter (Coq.FixBody, Coq.Sentence) - buildFixBodyAndInstance topLevelMap t recTypes = do - -- Locally visible definitions are defined in a local environment. - (fixBody, typeLevelMap, binders, instanceRetType) <- localEnv $ do - -- This map names necessary local functions and maps indirectly - -- recursive types to the appropriate function names. - typeLevelMap - <- nameFunctionsAndInsert functionPrefix topLevelMap recTypes - -- Name the argument of type @t@ given to the class - -- function. - topLevelVar <- freshCoqQualid freshArgPrefix - -- Compute class-specific binders and return types. - (binders, varBinder, retType, instanceRetType) - <- getBindersAndReturnTypes t topLevelVar - -- Build the implementation of the class function. - fixBody <- makeFixBody typeLevelMap topLevelVar t - (binders ++ [varBinder]) retType recTypes - return (fixBody, typeLevelMap, binders, instanceRetType) - -- Build the class instance for the given type. - -- The instance must be defined outside of a local environment so - -- that the instance name does not clash with any other names. - instanceDefinition <- buildInstance typeLevelMap t binders instanceRetType - return (fixBody, instanceDefinition) - - -- | Builds an instance for a specific type and typeclass. - buildInstance - :: TypeMap - -- ^ A mapping from (in)directly recursive types to function names. - -> IR.Type -- ^ The type for which we are defining an instance. - -> [Coq.Binder] -- ^ The binders for the type class instance. - -> Coq.Term -- ^ The type of the instance. - -> Converter Coq.Sentence - buildInstance m t binders retType = do - -- Define the class function as the function to which the current type - -- is mapped. - let instanceBody - = (Coq.bare functionPrefix, Coq.Qualid (fromJust (Map.lookup t m))) - instanceName <- Coq.bare <$> nameFunction className t - return - $ Coq.InstanceSentence - (Coq.InstanceDefinition instanceName (freeArgsBinders ++ binders) - retType [instanceBody] Nothing) - - -- | Generates the implementation of the body of a class function for the - -- given type. - makeFixBody - :: TypeMap - -- ^ A mapping from (in)directly recursive types to function names. - -> Coq.Qualid -- ^ The name of the argument of type @t@. - -> IR.Type -- ^ The type for which we are defining an instance. - -> [Coq.Binder] -- ^ The binders for the class function. - -> Coq.Term -- ^ The return type of the class function. - -> [IR.Type] -- ^ The list of indirectly recursive types. - -> Converter Coq.FixBody - makeFixBody m varName t binders retType recTypes = do - rhs <- generateBody m varName t recTypes - return - $ Coq.FixBody (fromJust (Map.lookup t m)) - (NonEmpty.fromList (freeArgsBinders ++ binders)) Nothing (Just retType) - rhs - - -- | Creates the function body for a class function by creating local - -- functions for all indirectly recursive types. - generateBody - :: TypeMap - -- ^ A mapping from (in)directly recursive types to function names. - -> Coq.Qualid -- ^ The name of the argument of type @t@. - -> IR.Type -- ^ The type for which we are defining an instance. - -> [IR.Type] -- ^ The list of indirectly recursive types. - -> Converter Coq.Term - - -- If there are no indirectly recursive types, match on the constructors of - -- the original type. - generateBody m varName t [] - = matchConstructors m varName t - -- For each indirectly recursive type, create a local function as a - -- @let fix@ declaration and generate the definition of the class function - -- for that type. - -- This local declaration is wrapped around all remaining declarations and - -- is therefore visible when defining them. - generateBody m varName t (recType : recTypes) = do - inBody <- generateBody m varName t recTypes - var <- freshCoqQualid freshArgPrefix - -- Create the body of the local function by matching on the type's - -- constructors. - letBody <- matchConstructors m var recType - (binders, varBinder, retType, _) <- getBindersAndReturnTypes recType var - let Just localFuncName = Map.lookup recType m - return - $ Coq.Let localFuncName [] Nothing - (Coq.Fix (Coq.FixOne (Coq.FixBody localFuncName - (NonEmpty.fromList (binders ++ [varBinder])) - Nothing (Just retType) letBody))) inBody - - -- | Matches on the constructors of a type. - matchConstructors :: TypeMap -> Coq.Qualid -> IR.Type -> Converter Coq.Term - matchConstructors m varName t = do - let Just conName = IR.getTypeConName t - entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName - equations <- mapM (buildEquation m t) (entryConsNames entry) - return $ Coq.match (Coq.Qualid varName) equations - - -- | Creates a match equation on a given data constructor with a - -- class-specific right-hand side. - buildEquation :: TypeMap -> IR.Type -> IR.ConName -> Converter Coq.Equation - buildEquation m t conName = do - conEntry <- lookupEntryOrFail NoSrcSpan IR.ValueScope conName - retType <- expandAllTypeSynonyms (entryReturnType conEntry) - -- Get the Coq name of the constructor. - let conIdent = entryIdent conEntry - -- Generate fresh variables for the constructor's parameters. - conArgIdents <- freshQualids (entryArity conEntry) ("f" ++ freshArgPrefix) - -- Replace all underscores with fresh variables before unification. - tFreshVars <- insertFreshVariables t - subst <- unifyOrFail NoSrcSpan tFreshVars retType - -- Find out the type of each constructor argument by unifying its return - -- type with the given type expression and applying the resulting - -- substitution to each constructor argument's type. - -- Then convert all irrelevant components to underscores again so the - -- type can be looked up in the type map. - expandedArgTypes <- mapM expandAllTypeSynonyms (entryArgTypes conEntry) - let modArgTypes = map (stripType . applySubst subst) expandedArgTypes - let lhs = Coq.ArgsPat conIdent (map Coq.QualidPat conArgIdents) - -- Build the right-hand side of the equation by applying the - -- class-specific function @buildValue@. - rhs <- buildValue m conIdent (zip modArgTypes conArgIdents) - return $ Coq.equation lhs rhs - - ------------------------------------------------------------------------------- - -- Functions to produce @Normalform@ instances -- - ------------------------------------------------------------------------------- - -- | The binders and return types for the @Normalform@ class function and instance. - nfBindersAndReturnType - :: IR.Type - -- ^ The type @t@ for which we are defining an instance. - -> Coq.Qualid -- ^ The name of the argument of type @t@. - -> Converter - ( [Coq.Binder] -- Type variable binders and @Normalform@ constraints. - , Coq.Binder -- Binder for the argument of type @t@. - , Coq.Term -- Return type of @nf'@. - , Coq.Term -- Return type of the @Normalform@ instance. - ) - nfBindersAndReturnType t varName = do - -- For each type variable in the type, generate two type variables. - -- One represents the type's variable itself, the other the result - -- type of the normalization. - -- The type is transformed to a Coq type twice, once with @Shape@ and - -- @Pos@ as arguments for the original type, once with @Identity.Shape@ - -- and @Identity.Pos@ as arguments for the normalized result type. - (sourceType, sourceVars) <- toCoqType "a" shapeAndPos t - (targetType, targetVars) <- toCoqType "b" idShapeAndPos t - -- For each type variable @ai@, build a constraint - -- @`{Normalform Shape Pos ai bi}@. - let constraints = zipWith Coq.Base.normalformBinder sourceVars targetVars - let varBinder - = [typeVarBinder (sourceVars ++ targetVars) | not (null sourceVars)] - let binders = varBinder ++ constraints - -- Create an explicit argument binder for the value to be normalized. - let topLevelVarBinder - = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit varName sourceType - let instanceRetType = Coq.app (Coq.Qualid Coq.Base.normalform) - (shapeAndPos ++ [sourceType, targetType]) - let funcRetType = applyFree targetType - return (binders, topLevelVarBinder, funcRetType, instanceRetType) - - -- | Builds a normalized @Free@ value for the given constructor - -- and constructor arguments. - buildNormalformValue - :: TypeMap - -- ^ A map to associate types with the appropriate functions to call. - -> Coq.Qualid -- ^ The data constructor used to build a value. - -> [(IR.Type, Coq.Qualid)] - -- ^ The types and names of the constructor's arguments. - -> Converter Coq.Term - buildNormalformValue nameMap consName = buildNormalformValue' [] - where - -- | Like 'buildNormalformValue', but with an additional parameter to accumulate - -- bound variables. - buildNormalformValue' - :: [Coq.Qualid] -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term - - -- If all components have been normalized, apply the constructor to - -- the normalized components. - buildNormalformValue' boundVars [] = do - args <- mapM (generatePure . Coq.Qualid) (reverse boundVars) - generatePure (Coq.app (Coq.Qualid consName) args) - -- For each component, apply the appropriate function, bind the - -- result and do the remaining computation. - buildNormalformValue' boundVars ((t, varName) : consVars) - = case Map.lookup t nameMap of - -- For recursive or indirectly recursive calls, the type map - -- returns the name of the appropriate function to call. - Just funcName -> do - -- Because the functions work on bare values, the component - -- must be bound (to a fresh variable). - x <- freshCoqQualid freshArgPrefix - -- The result of the normalization will also be bound to a fresh variable. - nx <- freshCoqQualid ("n" ++ freshArgPrefix) - -- Do the rest of the computation with the added bound result. - rhs <- buildNormalformValue' (nx : boundVars) consVars - -- Construct the actual bindings and return the result. - let c = Coq.fun [nx] [Nothing] rhs - let c' = applyBind (Coq.app (Coq.Qualid funcName) [Coq.Qualid x]) c - return $ applyBind (Coq.Qualid varName) (Coq.fun [x] [Nothing] c') - -- If there is no entry in the type map, we can assume that an instance - -- already exists. Therefore, we apply @nf@ to the component to receive - -- a normalized value. - Nothing -> do - nx <- freshCoqQualid ("n" ++ freshArgPrefix) - rhs <- buildNormalformValue' (nx : boundVars) consVars - let c = Coq.fun [nx] [Nothing] rhs - return - $ applyBind (Coq.app (Coq.Qualid Coq.Base.nf) [Coq.Qualid varName]) - c - - ------------------------------------------------------------------------------- - -- Functions to produce @ShareableArgs@ instances -- - ------------------------------------------------------------------------------- - -- | The binders and return types for the @ShareableArgs@ class function and instance. - shareArgsBindersAndReturnType - :: IR.Type - -- ^ The type @t@ for which we are defining an instance. - -> Coq.Qualid -- ^ The name of the argument of type @t@. - -> Converter - ( [Coq.Binder] -- Type variable binders and @ShareableArgs@ constraints. - , Coq.Binder -- Binder for the argument of type @t@. - , Coq.Term -- Return type of @shareArgs@. - , Coq.Term -- Return type of the @ShareableArgs@ instance. - ) - shareArgsBindersAndReturnType t varName = do - (coqType, vars) <- toCoqType "a" shapeAndPos t - let constraints - = Coq.Base.injectableBinder : map Coq.Base.shareableArgsBinder vars - let varBinder = [typeVarBinder vars | not (null vars)] - let binders = varBinder ++ constraints - let topLevelVarBinder - = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit varName coqType - let instanceRetType = Coq.app (Coq.Qualid Coq.Base.shareableArgs) - (shapeAndPos ++ [coqType]) - let funcRetType = applyFree coqType - return (binders, topLevelVarBinder, funcRetType, instanceRetType) - - -- | Shares all arguments of the given constructor and reconstructs the - -- value with the shared components. - buildShareArgsValue - :: TypeMap - -- ^ A map to associate types with the appropriate functions to call. - -> Coq.Qualid -- ^ The data constructor used to build a value. - -> [(IR.Type, Coq.Qualid)] - -- ^ The types and names of the constructor's arguments. - -> Converter Coq.Term - buildShareArgsValue nameMap consName = buildShareArgsValue' [] - where - buildShareArgsValue' - :: [Coq.Qualid] -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term - buildShareArgsValue' vals [] = generatePure - (Coq.app (Coq.Qualid consName) (map Coq.Qualid (reverse vals))) - buildShareArgsValue' vals ((t, varName) : consVars) = do - sx <- freshCoqQualid ("s" ++ freshArgPrefix) - rhs <- buildShareArgsValue' (sx : vals) consVars - case Map.lookup t nameMap of - Just funcName -> do - return - $ applyBind - (Coq.app (Coq.Qualid Coq.Base.cbneed) - (shapeAndPos ++ [Coq.Qualid funcName, Coq.Qualid varName])) - (Coq.fun [sx] [Nothing] rhs) - Nothing -> do - return - $ applyBind - (Coq.app (Coq.Qualid Coq.Base.cbneed) - (shapeAndPos - ++ [Coq.Qualid Coq.Base.shareArgs, Coq.Qualid varName])) - (Coq.fun [sx] [Nothing] rhs) - - ------------------------------------------------------------------------------- - -- Helper functions -- - ------------------------------------------------------------------------------- - -- | Creates an entry with a unique name for each of the given types and - -- inserts them into the given map. - nameFunctionsAndInsert :: String -> TypeMap -> [IR.Type] -> Converter TypeMap - nameFunctionsAndInsert prefix = foldM (nameFunctionAndInsert prefix) - - -- | Like 'nameFunctionsAndInsert', but for a single type. - nameFunctionAndInsert :: String -> TypeMap -> IR.Type -> Converter TypeMap - nameFunctionAndInsert prefix m t = do - name <- nameFunction prefix t - return (Map.insert t (Coq.bare name) m) - - -- | Names a function based on a type expression while avoiding name clashes - -- with other identifiers. - nameFunction :: String -> IR.Type -> Converter String - nameFunction prefix t = do - prettyType <- showPrettyType t - freshCoqIdent (prefix ++ prettyType) - - -- | A type variable that represents irrelevant parts of a type expression. - -- Represented by an underscore. - placeholderVar :: IR.Type - placeholderVar = IR.TypeVar NoSrcSpan "_" - - -- | Collects all fully-applied type constructors of arity at least 1 - -- (including their arguments) that occur in the given type. All arguments - -- that do not contain occurrences of the types for which we are defining - -- an instance are replaced by the type variable @_@. - -- The resulting list contains (in reverse topological order) exactly all - -- types for which we must define a separate function in the instance - -- definition, where all occurrences of @_@ represent the polymorphic - -- components of the function. - collectSubTypes :: IR.Type -> [IR.Type] - collectSubTypes = collectFullyAppliedTypes True - where - -- | Like 'collectSubTypes', but with an additional flag to denote whether - -- @t@ is a full application of a type constructor, e.g. @Pair Int Bool@, - -- or a partial application, e.g. @Pair Int@. - -- Only full applications are collected. - collectFullyAppliedTypes :: Bool -> IR.Type -> [IR.Type] - collectFullyAppliedTypes fullApplication t@(IR.TypeApp _ l r) - -- The left-hand side of a type application is the partial - -- application of a type constructor. - -- The right-hand side is a fully-applied type constructor, - -- a variable or a function type. - = let remainingTypes = collectFullyAppliedTypes False l - ++ collectFullyAppliedTypes True r - in if fullApplication - then stripType t : remainingTypes - else remainingTypes - -- Type variables, function types and type constructors with arity 0 are not - -- collected. - collectFullyAppliedTypes _ _ = [] - - -- | Returns the same type with all type expressions that do not contain one - -- of the type constructors for which we are defining instances replaced - -- with the type variable @_@. - stripType :: IR.Type -> IR.Type - stripType t = stripType' t False - where - -- | Like 'stripType', but with an additional flag to denote whether an - -- occurrence of a relevant type was found in an argument of a type - -- application. - -- This is necessary so that, for example, @Pair Bool t@ is not - -- transformed to @_ t@, but to @Pair _ t@. - stripType' :: IR.Type -> Bool -> IR.Type - stripType' (IR.TypeCon _ conName) flag - | flag || conName `elem` typeConNames = IR.TypeCon NoSrcSpan conName - | otherwise = placeholderVar - -- For a type application, check if a relevant type occurs in its - -- right-hand side. - stripType' (IR.TypeApp _ l r) flag = case stripType' r False of - -- If not, check if a relevant type occurs in its left-hand side, - -- otherwise replace the whole expression with an underscore. - r'@(IR.TypeVar _ _) -> case stripType' l flag of - IR.TypeVar _ _ -> placeholderVar - l' -> IR.TypeApp NoSrcSpan l' r' - -- If a relevant type does occur in the right-hand side, - -- the type application must be preserved, so only its arguments are - -- stripped. - r' -> IR.TypeApp NoSrcSpan (stripType' l True) r' - -- Type variables and function types are not relevant and are replaced by @_@. - stripType' _ _ = placeholderVar - - -- | Like @showPretty@, but uses the Coq identifiers of the type and its components. - showPrettyType :: IR.Type -> Converter String - - -- For a type variable, show its name. - showPrettyType (IR.TypeVar _ varName) = return (showPretty varName) - -- For a type constructor, return its Coq identifier as a string. - showPrettyType (IR.TypeCon _ conName) = fromJust . (>>= Coq.unpackQualid) - <$> inEnv (lookupIdent IR.TypeScope conName) - -- For a type application, convert both sides and concatenate them. - showPrettyType (IR.TypeApp _ l r) = do - lPretty <- showPrettyType l - rPretty <- showPrettyType r - return (lPretty ++ rPretty) - -- Function types should have been converted into variables. - showPrettyType (IR.FuncType _ _ _) - = error "Function types should have been eliminated." - - -- | Replaces all variables in a type with fresh variables. - insertFreshVariables :: IR.Type -> Converter IR.Type - insertFreshVariables (IR.TypeVar srcSpan _) = do - freshVar <- freshHaskellIdent freshArgPrefix - return (IR.TypeVar srcSpan freshVar) - insertFreshVariables (IR.TypeApp srcSpan l r) = do - lFresh <- insertFreshVariables l - rFresh <- insertFreshVariables r - return (IR.TypeApp srcSpan lFresh rFresh) - -- Type constructors and function types are returned as-is. - insertFreshVariables t = return t - - -- | Binders for (implicit) Shape and Pos arguments. - -- - -- > freeArgsBinders = [ {Shape : Type}, {Pos : Shape -> Type} ] - freeArgsBinders :: [Coq.Binder] - freeArgsBinders = genericArgDecls Coq.Implicit - - -- | Shortcut for the construction of an implicit binder for type variables. - -- - -- > typeVarBinder [α₁, …, an] = {α₁ …αₙ : Type} - typeVarBinder :: [Coq.Qualid] -> Coq.Binder - typeVarBinder typeVars - = Coq.typedBinder Coq.Ungeneralizable Coq.Implicit typeVars Coq.sortType - - -- | Shortcut for the application of @>>=@. - applyBind :: Coq.Term -> Coq.Term -> Coq.Term - applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [mx, f] - - -- | Given an @A@, returns @Free Shape Pos A@. - applyFree :: Coq.Term -> Coq.Term - applyFree a = genericApply Coq.Base.free [] [] [a] - - -- | @Shape@ and @Pos@ arguments as Coq terms. - shapeAndPos :: [Coq.Term] - shapeAndPos = [Coq.Qualid Coq.Base.shape, Coq.Qualid Coq.Base.pos] - - -- | The shape and position function arguments for the identity monad - -- as a Coq term. - idShapeAndPos :: [Coq.Term] - idShapeAndPos = map Coq.Qualid - [ Coq.Qualified (Coq.ident "Identity") Coq.Base.shapeIdent - , Coq.Qualified (Coq.ident "Identity") Coq.Base.posIdent - ] - - -- | Converts a type into a Coq type (a term) with the specified - -- additional arguments (for example @Shape@ and @Pos@) and fresh Coq - -- identifiers for all underscores. - -- Returns a pair of the result term and a list of the fresh variables. - toCoqType - :: String -- ^ The prefix of the fresh variables. - -> [Coq.Term] -- ^ A list of additional arguments, e.g. Shape and Pos. - -> IR.Type -- ^ The type to convert. - -> Converter (Coq.Term, [Coq.Qualid]) - - -- A type variable is translated into a fresh type variable. - toCoqType varPrefix _ (IR.TypeVar _ _) = do - x <- freshCoqQualid varPrefix - return (Coq.Qualid x, [x]) - -- A type constructor is applied to the given arguments. - toCoqType _ extraArgs (IR.TypeCon _ conName) = do - entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName - return (Coq.app (Coq.Qualid (entryIdent entry)) extraArgs, []) - -- For a type application, both arguments are translated recursively - -- and the collected variables are combined. - toCoqType varPrefix extraArgs (IR.TypeApp _ l r) = do - (l', varsl) <- toCoqType varPrefix extraArgs l - (r', varsr) <- toCoqType varPrefix extraArgs r - return (Coq.app l' [r'], varsl ++ varsr) - -- Function types were removed by 'stripType'. - toCoqType _ _ (IR.FuncType _ _ _) - = error "Function types should have been eliminated." - - -- | Produces @n@ new Coq identifiers (Qualids) with the same prefix. - freshQualids :: Int -> String -> Converter [Coq.Qualid] - freshQualids n prefix = replicateM n (freshCoqQualid prefix) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs new file mode 100644 index 00000000..5d6d08f5 --- /dev/null +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs @@ -0,0 +1,96 @@ +-- | This module contains functions to generate induction schemes for +-- user-defined data types. +module FreeC.Backend.Coq.Converter.TypeDecl.InductionScheme ( generateInductionScheme ) where + +import Control.Monad + ( mapAndUnzipM ) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe ( fromJust ) +import qualified Data.Text as Text + +import qualified FreeC.Backend.Coq.Base as Coq.Base +import FreeC.Backend.Coq.Converter.Arg +import FreeC.Backend.Coq.Converter.Free +import FreeC.Backend.Coq.Converter.Type +import qualified FreeC.Backend.Coq.Syntax as Coq +import FreeC.Environment +import FreeC.Environment.Fresh + ( freshArgPrefix, freshCoqIdent, freshCoqQualid ) +import qualified FreeC.IR.Syntax as IR +import FreeC.Monad.Converter + +-- | Generates an induction scheme for the given data type. +generateInductionScheme :: IR.TypeDecl -> Converter [Coq.Sentence] +generateInductionScheme (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = localEnv $ do + Just tIdent <- inEnv $ lookupIdent IR.TypeScope name + -- Create variables and binders. + let generateArg :: Coq.Term -> Converter (Coq.Qualid, Coq.Binder) + generateArg argType = do + ident <- freshCoqQualid freshArgPrefix + return + $ ( ident + , Coq.typedBinder Coq.Ungeneralizable Coq.Explicit [ident] argType + ) + (tvarIdents, tvarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls + (propIdent, propBinder) <- generateArg + (Coq.Arrow (genericApply tIdent [] [] (map Coq.Qualid tvarIdents)) + (Coq.Sort Coq.Prop)) + (_hIdents, hBinders) <- mapAndUnzipM (generateInductionCase propIdent) + conDecls + (valIdent, valBinder) <- generateArg + (genericApply tIdent [] [] (map Coq.Qualid tvarIdents)) + -- Stick everything together. + schemeName <- freshCoqQualid $ fromJust (Coq.unpackQualid tIdent) ++ "_Ind" + hypothesisVar <- freshCoqIdent "H" + let binders = genericArgDecls Coq.Explicit + ++ tvarBinders + ++ [propBinder] + ++ hBinders + term = Coq.Forall (NonEmpty.fromList [valBinder]) + (Coq.app (Coq.Qualid propIdent) [Coq.Qualid valIdent]) + scheme = Coq.Assertion Coq.Definition schemeName binders term + proof = Coq.ProofDefined + (Text.pack + $ " fix " + ++ hypothesisVar + ++ " 1; intro; " + ++ fromJust (Coq.unpackQualid Coq.Base.proveInd) + ++ ".") + return [Coq.AssertionSentence scheme proof] +-- Type synonyms are not allowed in this function. +generateInductionScheme (IR.TypeSynDecl _ _ _ _) + = error "generateInductionScheme: Type synonym not allowed." + +-- | Generates an induction case for a given property and constructor. +generateInductionCase + :: Coq.Qualid -> IR.ConDecl -> Converter (Coq.Qualid, Coq.Binder) +generateInductionCase pIdent (IR.ConDecl _ declIdent argTypes) = do + let conName = IR.declIdentName declIdent + Just conIdent <- inEnv $ lookupIdent IR.ValueScope conName + Just conType' <- inEnv $ lookupReturnType IR.ValueScope conName + conType <- convertType' conType' + fConType <- convertType conType' + fArgTypes <- mapM convertType argTypes + (argIdents, argBinders) <- mapAndUnzipM convertAnonymousArg + (map Just argTypes) + let + -- We need an induction hypothesis for every argument that has the same + -- type as the constructor but lifted into the free monad. + addHypotheses' :: [(Coq.Term, Coq.Qualid)] -> Coq.Term -> Coq.Term + addHypotheses' [] = id + addHypotheses' ((argType, argIdent) : args) + | argType == fConType = Coq.Arrow + (genericForFree conType pIdent argIdent) + . addHypotheses' args + addHypotheses' (_ : args) = addHypotheses' args + addHypotheses = addHypotheses' (zip fArgTypes argIdents) + -- Create induction case. + term = addHypotheses + (Coq.app (Coq.Qualid pIdent) + [Coq.app (Coq.Qualid conIdent) (map Coq.Qualid argIdents)]) + indCase = if null argBinders + then term + else Coq.Forall (NonEmpty.fromList argBinders) term + indCaseIdent <- freshCoqQualid freshArgPrefix + indCaseBinder <- generateArgBinder indCaseIdent (Just indCase) + return (indCaseIdent, indCaseBinder) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs new file mode 100644 index 00000000..c1b58ced --- /dev/null +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs @@ -0,0 +1,677 @@ +-- | This module contains functions to generate instances for supported +-- typeclasses for user-defined Haskell data types. +-- +-- Suppose we have a type +-- > data T α₁ … αₙ = C₁ τ₍₁,₁₎ … τ₍₁,ₘ₁₎ | … | Cₖ τ₍ₖ,₁₎ … τ₍ₖ,ₘₖ₎. +-- We wish to generate an instance of class @C@ providing the function +-- @f : T α₁ … αₙ -> τ@, where @τ@ is a type. +-- For example, for the @Normalform@ class, @f@ would be +-- > nf' : T α₁ … αₙ -> Free Shape Pos (T α₁ … αₙ). +-- +-- The generated function has the following basic structure: +-- +-- > f'T < class-specific binders > (x : T α₁ … αₙ) : B +-- > := match x with +-- > | C₁ fx₍₁,₁₎ … fx₍₁,ₘ₁₎ => < buildValue x [fx₍₁,₁₎, …, fx₍₁,ₘ₁₎ > +-- > | … +-- > | Cₖ fx₍ₖ,₁₎ … fx₍ₖ,ₘₖ₎ => < buildValue x [fx₍ₖ,₁₎, …, fxk₍ₖ,ₘₖ₎] > +-- > end. +-- +-- @buildValue x [fx₍ᵢ,₁₎, …, fx₍ᵢ,ₘᵢ₎]@ represents class-specific code that +-- actually constructs a value of type @τ@ when given @x@ and the +-- constructor's parameters as arguments. +-- +-- For example, for a @Normalform@ instance of a type +-- @data List a = Nil | Cons a (List a)@, +-- the function would look as follows. +-- +-- > nf'List_ {Shape : Type} {Pos : Shape -> Type} +-- > {a b : Type} `{Normalform Shape Pos a b} +-- > (x : List Shape Pos a) +-- > : Free Shape Pos (List Identity.Shape Identity.Pos b) +-- > := match x with +-- > | nil => pure nil +-- > | cons fx_0 fx_1 => nf fx_0 >>= fun nx_0 => +-- > fx_1 >>= fun x_1 => +-- > nf'List x_1 >>= fun nx_1 => +-- > pure (cons (pure nx_0) (pure nx_1)) +-- > end. +-- +-- Typically, @buildValue@ will use the class function @f@ on all components, +-- then reconstruct the value using the results of those function calls. +-- In the example above, we use @nf@ on @fx_0@ of type @a@. @nf fx_0@ means +-- the same as @fx_0 >>= fun x_0 => nf' x_0@. +-- +-- Since we translate types in topological order and @C@ instances exist for +-- all previously translated types (and types from the Prelude), we can use +-- @f@ on most arguments. +-- For all type variables, we introduce class constraints into the type +-- signature of the function. +-- However, this is not possible for (indirectly) recursive arguments. +-- +-- A directly recursive argument has the type @T τ₁ … τₙ@, where @τᵢ@ is a +-- type expressions (not necessarily type variables). We assume that @τᵢ'@ +-- does not contain @T@ for any @i@, as this would constitute a non-positive +-- occurrence of @T@ and make @T@ invalid in Coq. +-- For these arguments, instead of the function @f@ we call @fT@ recursively. +-- +-- An indirectly recursive argument is an argument of a type that is not @T@, +-- but contains @T@. +-- These arguments are problematic because we can neither use @f@ on them +-- (as that would generally require a @C@ instance of @T@) nor can we use +-- @fT@. +-- +-- The problem is solved by introducing a local function @fT'@ for every type +-- @T'@ that contains @T@ that inlines the definition of a @T'@ instance of +-- @C@, and call this function for arguments of type @T'@. +-- These local functions are as polymorphic as possible to reduce the number +-- of local functions we need. +-- +-- For example, if we want to generate an instance for the Haskell type +-- +-- > data Forest a = AForest [Forest a] +-- > | IntForest [Forest Int] +-- > | BoolForest [Forest Bool] +-- +-- only one local function is needed. In the case of @Normalform@, the local +-- function would look as follows. +-- +-- > nf'ListForest_ {a b : Type} `{Normalform Shape Pos a b} +-- > : List Shape Pos (Forest Shape Pos a) +-- > -> Free Shape Pos (List Identity.Shape Identity.Pos +-- > (Forest Identity.Shape Identity.Pos b)) +-- +-- To generate these local functions, for every type expression @τ₍ᵢ,ⱼ₎@ in the +-- constructors of @T@, we collect all types that contain the original type +-- @T@. +-- More specifically, a type expression @T' τ₁ … τₙ@ is collected if +-- @τᵢ = T τ₁' … τₙ'@ for some type expressions @τ₁, …, τₙ@, or if @τᵢ@ +-- is collected for some @i@. +-- During this process, any type expression that does not contain @T@ is +-- replaced by a placeholder variable @_@. +-- +-- We keep track of which types correspond to which function with a map. +-- +-- The generated functions @fT₁, …, fTₙ@ for @n@ mutually recursive types +-- @T₁, … Tₙ@ are a set of @n@ @Fixpoint@ definitions linked with @with@. +-- Indirectly recursive types and local functions based on them are computed +-- for each type. +-- In this case, a type @T'@ is considered indirectly recursive if it +-- contains any of the types @T₁, …, Tₙ@. +-- Arguments of type @Tᵢ@ can be treated like directly recursive arguments. + + +module FreeC.Backend.Coq.Converter.TypeDecl.TypeclassInstances where + +import Control.Monad + ( foldM, mapAndUnzipM, replicateM ) +import Data.List ( nub ) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import Data.Maybe ( fromJust ) + +import qualified FreeC.Backend.Coq.Base as Coq.Base +import FreeC.Backend.Coq.Converter.Free +import qualified FreeC.Backend.Coq.Syntax as Coq +import FreeC.Environment +import FreeC.Environment.Entry +import FreeC.Environment.Fresh + ( freshArgPrefix, freshCoqQualid, freshHaskellIdent ) +import FreeC.Environment.LookupOrFail +import FreeC.IR.SrcSpan ( SrcSpan(NoSrcSpan) ) +import FreeC.IR.Subst +import qualified FreeC.IR.Syntax as IR +import FreeC.IR.TypeSynExpansion +import FreeC.IR.Unification +import FreeC.Monad.Converter +import FreeC.Pretty + +------------------------------------------------------------------------------- +-- Instance Generation -- +------------------------------------------------------------------------------- + +-- | Type synonym for a map mapping types to function names. +type TypeMap = Map.Map IR.Type Coq.Qualid + +-- | Builds instances for all supported typeclasses. +-- Currently, @Normalform@ and @ShareableArgs@ instances are generated. +generateTypeclassInstances :: [IR.TypeDecl] -> Converter [Coq.Sentence] +generateTypeclassInstances dataDecls = do + -- The types of the data declaration's constructors' arguments. + let argTypes = map (concatMap IR.conDeclFields . IR.dataDeclCons) dataDecls + -- The same types where all type synonyms are expanded. + argTypesExpanded <- mapM (mapM expandAllTypeSynonyms) argTypes + -- A list where all fully-applied type constructors that do not contain one of the types + -- for which we are defining instances and all type variables are replaced with + -- the same type variable (an underscore). The list is reversed so its entries are + -- in topological order. + let reducedTypes = map (nub . reverse . concatMap collectSubTypes) + argTypesExpanded + -- Like 'reducedTypes', but with all occurrences of the types for which we are defining + -- instances and all type variables removed from the list. + -- This leaves exactly the types with indirect recursion, with all non-recursive + -- components replaced by underscores. + let recTypeList = map + (filter (\t -> not (t `elem` declTypes || IR.isTypeVar t))) reducedTypes + -- Construct @Normalform@ instances. + nfInstances <- buildInstances recTypeList + (fromJust $ Coq.unpackQualid Coq.Base.nf') + (fromJust $ Coq.unpackQualid Coq.Base.normalform) nfBindersAndReturnType + buildNormalformValue + -- Construct @ShareableArgs@ instances. + shareableArgsInstances <- buildInstances recTypeList + (fromJust $ Coq.unpackQualid Coq.Base.shareArgs) + (fromJust $ Coq.unpackQualid Coq.Base.shareableArgs) + shareArgsBindersAndReturnType buildShareArgsValue + return (nfInstances ++ shareableArgsInstances) + where + -- | The (mutually recursive) data types for which we are defining + -- instances, converted to types. All type variable are converted + -- to underscores. + declTypes :: [IR.Type] + declTypes = [IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) + (replicate (length (IR.typeDeclArgs dataDecl)) placeholderVar) + | dataDecl <- dataDecls + ] + + -- The names of the type constructors of the data types for which + -- we are defining instances. + typeConNames :: [IR.TypeConName] + typeConNames = map IR.typeDeclQName dataDecls + + -- | Constructs instances of a typeclass for a set of mutually recursive + -- types. The typeclass is specified by the arguments. + buildInstances + :: [[IR.Type]] + -- ^ For each data declaration, this list contains the occurrences of + -- indirect recursion in the constructors of that data declaration. + -> String -- ^ The name of the class function. + -> String -- ^ The name of the typeclass. + -> (IR.Type + -> Coq.Qualid + -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term)) + -- ^ A function to get class-specific binders and return types. + -> (TypeMap -> Coq.Qualid -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term) + -- ^ A function to compute a class-specific value given a data constructor + -- with arguments. + -> Converter [Coq.Sentence] + buildInstances recTypeList functionPrefix className getBindersAndReturnTypes + buildValue = do + -- This map defines the name of the top-level class function for each + -- of the mutually recursive types. + -- It must be defined outside of a local environment to prevent any + -- clashes of the function names with other names. + topLevelMap <- nameFunctionsAndInsert functionPrefix Map.empty declTypes + (fixBodies, instances) <- mapAndUnzipM + (uncurry (buildFixBodyAndInstance topLevelMap)) + (zip declTypes recTypeList) + return + $ Coq.comment (className + ++ " instance" + ++ ['s' | length dataDecls > 1] + ++ " for " + ++ showPretty (map IR.typeDeclName dataDecls)) + : Coq.FixpointSentence (Coq.Fixpoint (NonEmpty.fromList fixBodies) []) + : instances + where + -- Constructs the class function and class instance for a single type. + buildFixBodyAndInstance + :: TypeMap + -- ^ A map to map occurrences of the top-level types to recursive + -- function calls. + -> IR.Type -- ^ The type for which we are defining an instance. + -> [IR.Type] -- ^ The list of indirectly recursive types. + -> Converter (Coq.FixBody, Coq.Sentence) + buildFixBodyAndInstance topLevelMap t recTypes = do + -- Locally visible definitions are defined in a local environment. + (fixBody, typeLevelMap, binders, instanceRetType) <- localEnv $ do + -- This map names necessary local functions and maps indirectly + -- recursive types to the appropriate function names. + typeLevelMap + <- nameFunctionsAndInsert functionPrefix topLevelMap recTypes + -- Name the argument of type @t@ given to the class + -- function. + topLevelVar <- freshCoqQualid freshArgPrefix + -- Compute class-specific binders and return types. + (binders, varBinder, retType, instanceRetType) + <- getBindersAndReturnTypes t topLevelVar + -- Build the implementation of the class function. + fixBody <- makeFixBody typeLevelMap topLevelVar t + (binders ++ [varBinder]) retType recTypes + return (fixBody, typeLevelMap, binders, instanceRetType) + -- Build the class instance for the given type. + -- The instance must be defined outside of a local environment so + -- that the instance name does not clash with any other names. + instanceDefinition <- buildInstance typeLevelMap t binders instanceRetType + return (fixBody, instanceDefinition) + + -- | Builds an instance for a specific type and typeclass. + buildInstance + :: TypeMap + -- ^ A mapping from (in)directly recursive types to function names. + -> IR.Type -- ^ The type for which we are defining an instance. + -> [Coq.Binder] -- ^ The binders for the type class instance. + -> Coq.Term -- ^ The type of the instance. + -> Converter Coq.Sentence + buildInstance m t binders retType = do + -- Define the class function as the function to which the current type + -- is mapped. + let instanceBody + = (Coq.bare functionPrefix, Coq.Qualid (fromJust (Map.lookup t m))) + instanceName <- nameFunction className t + return + $ Coq.InstanceSentence + (Coq.InstanceDefinition instanceName (freeArgsBinders ++ binders) + retType [instanceBody] Nothing) + + -- | Generates the implementation of the body of a class function for the + -- given type. + makeFixBody + :: TypeMap + -- ^ A mapping from (in)directly recursive types to function names. + -> Coq.Qualid -- ^ The name of the argument of type @t@. + -> IR.Type -- ^ The type for which we are defining an instance. + -> [Coq.Binder] -- ^ The binders for the class function. + -> Coq.Term -- ^ The return type of the class function. + -> [IR.Type] -- ^ The list of indirectly recursive types. + -> Converter Coq.FixBody + makeFixBody m varName t binders retType recTypes = do + rhs <- generateBody m varName t recTypes + return + $ Coq.FixBody (fromJust (Map.lookup t m)) + (NonEmpty.fromList (freeArgsBinders ++ binders)) Nothing (Just retType) + rhs + + -- | Creates the function body for a class function by creating local + -- functions for all indirectly recursive types. + generateBody + :: TypeMap + -- ^ A mapping from (in)directly recursive types to function names. + -> Coq.Qualid -- ^ The name of the argument of type @t@. + -> IR.Type -- ^ The type for which we are defining an instance. + -> [IR.Type] -- ^ The list of indirectly recursive types. + -> Converter Coq.Term + + -- If there are no indirectly recursive types, match on the constructors of + -- the original type. + generateBody m varName t [] + = matchConstructors m varName t + -- For each indirectly recursive type, create a local function as a + -- @let fix@ declaration and generate the definition of the class function + -- for that type. + -- This local declaration is wrapped around all remaining declarations and + -- is therefore visible when defining them. + generateBody m varName t (recType : recTypes) = do + inBody <- generateBody m varName t recTypes + var <- freshCoqQualid freshArgPrefix + -- Create the body of the local function by matching on the type's + -- constructors. + letBody <- matchConstructors m var recType + (binders, varBinder, retType, _) <- getBindersAndReturnTypes recType var + let Just localFuncName = Map.lookup recType m + return + $ Coq.Let localFuncName [] Nothing + (Coq.Fix (Coq.FixOne (Coq.FixBody localFuncName + (NonEmpty.fromList (binders ++ [varBinder])) + Nothing (Just retType) letBody))) inBody + + -- | Matches on the constructors of a type. + matchConstructors :: TypeMap -> Coq.Qualid -> IR.Type -> Converter Coq.Term + matchConstructors m varName t = do + let Just conName = IR.getTypeConName t + entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName + equations <- mapM (buildEquation m t) (entryConsNames entry) + return $ Coq.match (Coq.Qualid varName) equations + + -- | Creates a match equation on a given data constructor with a + -- class-specific right-hand side. + buildEquation :: TypeMap -> IR.Type -> IR.ConName -> Converter Coq.Equation + buildEquation m t conName = do + conEntry <- lookupEntryOrFail NoSrcSpan IR.ValueScope conName + retType <- expandAllTypeSynonyms (entryReturnType conEntry) + -- Get the Coq name of the constructor. + let conIdent = entryIdent conEntry + -- Generate fresh variables for the constructor's parameters. + conArgIdents <- freshQualids (entryArity conEntry) ("f" ++ freshArgPrefix) + -- Replace all underscores with fresh variables before unification. + tFreshVars <- insertFreshVariables t + subst <- unifyOrFail NoSrcSpan tFreshVars retType + -- Find out the type of each constructor argument by unifying its return + -- type with the given type expression and applying the resulting + -- substitution to each constructor argument's type. + -- Then convert all irrelevant components to underscores again so the + -- type can be looked up in the type map. + expandedArgTypes <- mapM expandAllTypeSynonyms (entryArgTypes conEntry) + let modArgTypes = map (stripType . applySubst subst) expandedArgTypes + let lhs = Coq.ArgsPat conIdent (map Coq.QualidPat conArgIdents) + -- Build the right-hand side of the equation by applying the + -- class-specific function @buildValue@. + rhs <- buildValue m conIdent (zip modArgTypes conArgIdents) + return $ Coq.equation lhs rhs + + ------------------------------------------------------------------------------- + -- Functions to produce @Normalform@ instances -- + ------------------------------------------------------------------------------- + -- | The binders and return types for the @Normalform@ class function and instance. + nfBindersAndReturnType + :: IR.Type + -- ^ The type @t@ for which we are defining an instance. + -> Coq.Qualid -- ^ The name of the argument of type @t@. + -> Converter + ( [Coq.Binder] -- Type variable binders and @Normalform@ constraints. + , Coq.Binder -- Binder for the argument of type @t@. + , Coq.Term -- Return type of @nf'@. + , Coq.Term -- Return type of the @Normalform@ instance. + ) + nfBindersAndReturnType t varName = do + -- For each type variable in the type, generate two type variables. + -- One represents the type's variable itself, the other the result + -- type of the normalization. + -- The type is transformed to a Coq type twice, once with @Shape@ and + -- @Pos@ as arguments for the original type, once with @Identity.Shape@ + -- and @Identity.Pos@ as arguments for the normalized result type. + (sourceType, sourceVars) <- toCoqType "a" shapeAndPos t + (targetType, targetVars) <- toCoqType "b" idShapeAndPos t + -- For each type variable @ai@, build a constraint + -- @`{Normalform Shape Pos ai bi}@. + let constraints = zipWith Coq.Base.normalformBinder sourceVars targetVars + let varBinder + = [typeVarBinder (sourceVars ++ targetVars) | not (null sourceVars)] + let binders = varBinder ++ constraints + -- Create an explicit argument binder for the value to be normalized. + let topLevelVarBinder + = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit varName sourceType + let instanceRetType = Coq.app (Coq.Qualid Coq.Base.normalform) + (shapeAndPos ++ [sourceType, targetType]) + let funcRetType = applyFree targetType + return (binders, topLevelVarBinder, funcRetType, instanceRetType) + + -- | Builds a normalized @Free@ value for the given constructor + -- and constructor arguments. + buildNormalformValue + :: TypeMap + -- ^ A map to associate types with the appropriate functions to call. + -> Coq.Qualid -- ^ The data constructor used to build a value. + -> [(IR.Type, Coq.Qualid)] + -- ^ The types and names of the constructor's arguments. + -> Converter Coq.Term + buildNormalformValue nameMap consName = buildNormalformValue' [] + where + -- | Like 'buildNormalformValue', but with an additional parameter to accumulate + -- bound variables. + buildNormalformValue' + :: [Coq.Qualid] -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term + + -- If all components have been normalized, apply the constructor to + -- the normalized components. + buildNormalformValue' boundVars [] = do + args <- mapM (generatePure . Coq.Qualid) (reverse boundVars) + generatePure (Coq.app (Coq.Qualid consName) args) + -- For each component, apply the appropriate function, bind the + -- result and do the remaining computation. + buildNormalformValue' boundVars ((t, varName) : consVars) + = case Map.lookup t nameMap of + -- For recursive or indirectly recursive calls, the type map + -- returns the name of the appropriate function to call. + Just funcName -> do + -- Because the functions work on bare values, the component + -- must be bound (to a fresh variable). + x <- freshCoqQualid freshArgPrefix + -- The result of the normalization will also be bound to a fresh variable. + nx <- freshCoqQualid ("n" ++ freshArgPrefix) + -- Do the rest of the computation with the added bound result. + rhs <- buildNormalformValue' (nx : boundVars) consVars + -- Construct the actual bindings and return the result. + let c = Coq.fun [nx] [Nothing] rhs + let c' = applyBind (Coq.app (Coq.Qualid funcName) [Coq.Qualid x]) c + return $ applyBind (Coq.Qualid varName) (Coq.fun [x] [Nothing] c') + -- If there is no entry in the type map, we can assume that an instance + -- already exists. Therefore, we apply @nf@ to the component to receive + -- a normalized value. + Nothing -> do + nx <- freshCoqQualid ("n" ++ freshArgPrefix) + rhs <- buildNormalformValue' (nx : boundVars) consVars + let c = Coq.fun [nx] [Nothing] rhs + return + $ applyBind (Coq.app (Coq.Qualid Coq.Base.nf) [Coq.Qualid varName]) + c + + ------------------------------------------------------------------------------- + -- Functions to produce @ShareableArgs@ instances -- + ------------------------------------------------------------------------------- + -- | The binders and return types for the @ShareableArgs@ class function and instance. + shareArgsBindersAndReturnType + :: IR.Type + -- ^ The type @t@ for which we are defining an instance. + -> Coq.Qualid -- ^ The name of the argument of type @t@. + -> Converter + ( [Coq.Binder] -- Type variable binders and @ShareableArgs@ constraints. + , Coq.Binder -- Binder for the argument of type @t@. + , Coq.Term -- Return type of @shareArgs@. + , Coq.Term -- Return type of the @ShareableArgs@ instance. + ) + shareArgsBindersAndReturnType t varName = do + (coqType, vars) <- toCoqType "a" shapeAndPos t + let constraints + = Coq.Base.injectableBinder : map Coq.Base.shareableArgsBinder vars + let varBinder = [typeVarBinder vars | not (null vars)] + let binders = varBinder ++ constraints + let topLevelVarBinder + = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit varName coqType + let instanceRetType = Coq.app (Coq.Qualid Coq.Base.shareableArgs) + (shapeAndPos ++ [coqType]) + let funcRetType = applyFree coqType + return (binders, topLevelVarBinder, funcRetType, instanceRetType) + + -- | Shares all arguments of the given constructor and reconstructs the + -- value with the shared components. + buildShareArgsValue + :: TypeMap + -- ^ A map to associate types with the appropriate functions to call. + -> Coq.Qualid -- ^ The data constructor used to build a value. + -> [(IR.Type, Coq.Qualid)] + -- ^ The types and names of the constructor's arguments. + -> Converter Coq.Term + buildShareArgsValue nameMap consName = buildShareArgsValue' [] + where + buildShareArgsValue' + :: [Coq.Qualid] -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term + buildShareArgsValue' vals [] = generatePure + (Coq.app (Coq.Qualid consName) (map Coq.Qualid (reverse vals))) + buildShareArgsValue' vals ((t, varName) : consVars) = do + sx <- freshCoqQualid ("s" ++ freshArgPrefix) + rhs <- buildShareArgsValue' (sx : vals) consVars + case Map.lookup t nameMap of + Just funcName -> do + return + $ applyBind + (Coq.app (Coq.Qualid Coq.Base.cbneed) + (shapeAndPos ++ [Coq.Qualid funcName, Coq.Qualid varName])) + (Coq.fun [sx] [Nothing] rhs) + Nothing -> do + return + $ applyBind + (Coq.app (Coq.Qualid Coq.Base.cbneed) + (shapeAndPos + ++ [Coq.Qualid Coq.Base.shareArgs, Coq.Qualid varName])) + (Coq.fun [sx] [Nothing] rhs) + + ------------------------------------------------------------------------------- + -- Helper functions -- + ------------------------------------------------------------------------------- + -- | Creates an entry with a unique name for each of the given types and + -- inserts them into the given map. + nameFunctionsAndInsert :: String -> TypeMap -> [IR.Type] -> Converter TypeMap + nameFunctionsAndInsert prefix = foldM (nameFunctionAndInsert prefix) + + -- | Like 'nameFunctionsAndInsert', but for a single type. + nameFunctionAndInsert :: String -> TypeMap -> IR.Type -> Converter TypeMap + nameFunctionAndInsert prefix m t = do + name <- nameFunction prefix t + return (Map.insert t name m) + + -- | Names a function based on a type expression while avoiding name clashes + -- with other identifiers. + nameFunction :: String -> IR.Type -> Converter Coq.Qualid + nameFunction prefix t = do + prettyType <- showPrettyType t + freshCoqQualid (prefix ++ prettyType) + + -- | A type variable that represents irrelevant parts of a type expression. + -- Represented by an underscore. + placeholderVar :: IR.Type + placeholderVar = IR.TypeVar NoSrcSpan "_" + + -- | Collects all fully-applied type constructors of arity at least 1 + -- (including their arguments) that occur in the given type. All arguments + -- that do not contain occurrences of the types for which we are defining + -- an instance are replaced by the type variable @_@. + -- The resulting list contains (in reverse topological order) exactly all + -- types for which we must define a separate function in the instance + -- definition, where all occurrences of @_@ represent the polymorphic + -- components of the function. + collectSubTypes :: IR.Type -> [IR.Type] + collectSubTypes = collectFullyAppliedTypes True + where + -- | Like 'collectSubTypes', but with an additional flag to denote whether + -- @t@ is a full application of a type constructor, e.g. @Pair Int Bool@, + -- or a partial application, e.g. @Pair Int@. + -- Only full applications are collected. + collectFullyAppliedTypes :: Bool -> IR.Type -> [IR.Type] + collectFullyAppliedTypes fullApplication t@(IR.TypeApp _ l r) + -- The left-hand side of a type application is the partial + -- application of a type constructor. + -- The right-hand side is a fully-applied type constructor, + -- a variable or a function type. + = let remainingTypes = collectFullyAppliedTypes False l + ++ collectFullyAppliedTypes True r + in if fullApplication + then stripType t : remainingTypes + else remainingTypes + -- Type variables, function types and type constructors with arity 0 are not + -- collected. + collectFullyAppliedTypes _ _ = [] + + -- | Returns the same type with all type expressions that do not contain one + -- of the type constructors for which we are defining instances replaced + -- with the type variable @_@. + stripType :: IR.Type -> IR.Type + stripType t = stripType' t False + where + -- | Like 'stripType', but with an additional flag to denote whether an + -- occurrence of a relevant type was found in an argument of a type + -- application. + -- This is necessary so that, for example, @Pair Bool t@ is not + -- transformed to @_ t@, but to @Pair _ t@. + stripType' :: IR.Type -> Bool -> IR.Type + stripType' (IR.TypeCon _ conName) flag + | flag || conName `elem` typeConNames = IR.TypeCon NoSrcSpan conName + | otherwise = placeholderVar + -- For a type application, check if a relevant type occurs in its + -- right-hand side. + stripType' (IR.TypeApp _ l r) flag = case stripType' r False of + -- If not, check if a relevant type occurs in its left-hand side, + -- otherwise replace the whole expression with an underscore. + r'@(IR.TypeVar _ _) -> case stripType' l flag of + IR.TypeVar _ _ -> placeholderVar + l' -> IR.TypeApp NoSrcSpan l' r' + -- If a relevant type does occur in the right-hand side, + -- the type application must be preserved, so only its arguments are + -- stripped. + r' -> IR.TypeApp NoSrcSpan (stripType' l True) r' + -- Type variables and function types are not relevant and are replaced by @_@. + stripType' _ _ = placeholderVar + + -- | Like @showPretty@, but uses the Coq identifiers of the type and its components. + showPrettyType :: IR.Type -> Converter String + + -- For a type variable, show its name. + showPrettyType (IR.TypeVar _ varName) = return (showPretty varName) + -- For a type constructor, return its Coq identifier as a string. + showPrettyType (IR.TypeCon _ conName) = fromJust . (>>= Coq.unpackQualid) + <$> inEnv (lookupIdent IR.TypeScope conName) + -- For a type application, convert both sides and concatenate them. + showPrettyType (IR.TypeApp _ l r) = do + lPretty <- showPrettyType l + rPretty <- showPrettyType r + return (lPretty ++ rPretty) + -- Function types should have been converted into variables. + showPrettyType (IR.FuncType _ _ _) + = error "Function types should have been eliminated." + + -- | Replaces all variables in a type with fresh variables. + insertFreshVariables :: IR.Type -> Converter IR.Type + insertFreshVariables (IR.TypeVar srcSpan _) = do + freshVar <- freshHaskellIdent freshArgPrefix + return (IR.TypeVar srcSpan freshVar) + insertFreshVariables (IR.TypeApp srcSpan l r) = do + lFresh <- insertFreshVariables l + rFresh <- insertFreshVariables r + return (IR.TypeApp srcSpan lFresh rFresh) + -- Type constructors and function types are returned as-is. + insertFreshVariables t = return t + + -- | Binders for (implicit) Shape and Pos arguments. + -- + -- > freeArgsBinders = [ {Shape : Type}, {Pos : Shape -> Type} ] + freeArgsBinders :: [Coq.Binder] + freeArgsBinders = genericArgDecls Coq.Implicit + + -- | Shortcut for the construction of an implicit binder for type variables. + -- + -- > typeVarBinder [α₁, …, an] = {α₁ …αₙ : Type} + typeVarBinder :: [Coq.Qualid] -> Coq.Binder + typeVarBinder typeVars + = Coq.typedBinder Coq.Ungeneralizable Coq.Implicit typeVars Coq.sortType + + -- | Shortcut for the application of @>>=@. + applyBind :: Coq.Term -> Coq.Term -> Coq.Term + applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [mx, f] + + -- | Given an @A@, returns @Free Shape Pos A@. + applyFree :: Coq.Term -> Coq.Term + applyFree a = genericApply Coq.Base.free [] [] [a] + + -- | @Shape@ and @Pos@ arguments as Coq terms. + shapeAndPos :: [Coq.Term] + shapeAndPos = [Coq.Qualid Coq.Base.shape, Coq.Qualid Coq.Base.pos] + + -- | The shape and position function arguments for the identity monad + -- as a Coq term. + idShapeAndPos :: [Coq.Term] + idShapeAndPos = map Coq.Qualid + [ Coq.Qualified (Coq.ident "Identity") Coq.Base.shapeIdent + , Coq.Qualified (Coq.ident "Identity") Coq.Base.posIdent + ] + + -- | Converts a type into a Coq type (a term) with the specified + -- additional arguments (for example @Shape@ and @Pos@) and fresh Coq + -- identifiers for all underscores. + -- Returns a pair of the result term and a list of the fresh variables. + toCoqType + :: String -- ^ The prefix of the fresh variables. + -> [Coq.Term] -- ^ A list of additional arguments, e.g. Shape and Pos. + -> IR.Type -- ^ The type to convert. + -> Converter (Coq.Term, [Coq.Qualid]) + + -- A type variable is translated into a fresh type variable. + toCoqType varPrefix _ (IR.TypeVar _ _) = do + x <- freshCoqQualid varPrefix + return (Coq.Qualid x, [x]) + -- A type constructor is applied to the given arguments. + toCoqType _ extraArgs (IR.TypeCon _ conName) = do + entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName + return (Coq.app (Coq.Qualid (entryIdent entry)) extraArgs, []) + -- For a type application, both arguments are translated recursively + -- and the collected variables are combined. + toCoqType varPrefix extraArgs (IR.TypeApp _ l r) = do + (l', varsl) <- toCoqType varPrefix extraArgs l + (r', varsr) <- toCoqType varPrefix extraArgs r + return (Coq.app l' [r'], varsl ++ varsr) + -- Function types were removed by 'stripType'. + toCoqType _ _ (IR.FuncType _ _ _) + = error "Function types should have been eliminated." + + -- | Produces @n@ new Coq identifiers (Qualids) with the same prefix. + freshQualids :: Int -> String -> Converter [Coq.Qualid] + freshQualids n prefix = replicateM n (freshCoqQualid prefix) From c068f505a10a312ba3d2c17a2029ff128813a067 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 20 Sep 2020 13:12:59 +0200 Subject: [PATCH 079/120] Format code #150 --- .../Coq/Converter/TypeDecl/InductionScheme.hs | 69 ++++++++++--------- .../Converter/TypeDecl/TypeclassInstances.hs | 3 - 2 files changed, 35 insertions(+), 37 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs index 5d6d08f5..824cb170 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs @@ -1,9 +1,10 @@ -- | This module contains functions to generate induction schemes for -- user-defined data types. -module FreeC.Backend.Coq.Converter.TypeDecl.InductionScheme ( generateInductionScheme ) where +module FreeC.Backend.Coq.Converter.TypeDecl.InductionScheme + ( generateInductionScheme + ) where -import Control.Monad - ( mapAndUnzipM ) +import Control.Monad ( mapAndUnzipM ) import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe ( fromJust ) import qualified Data.Text as Text @@ -21,7 +22,8 @@ import FreeC.Monad.Converter -- | Generates an induction scheme for the given data type. generateInductionScheme :: IR.TypeDecl -> Converter [Coq.Sentence] -generateInductionScheme (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = localEnv $ do +generateInductionScheme + (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = localEnv $ do Just tIdent <- inEnv $ lookupIdent IR.TypeScope name -- Create variables and binders. let generateArg :: Coq.Term -> Converter (Coq.Qualid, Coq.Binder) @@ -63,34 +65,33 @@ generateInductionScheme (IR.TypeSynDecl _ _ _ _) -- | Generates an induction case for a given property and constructor. generateInductionCase - :: Coq.Qualid -> IR.ConDecl -> Converter (Coq.Qualid, Coq.Binder) + :: Coq.Qualid -> IR.ConDecl -> Converter (Coq.Qualid, Coq.Binder) generateInductionCase pIdent (IR.ConDecl _ declIdent argTypes) = do - let conName = IR.declIdentName declIdent - Just conIdent <- inEnv $ lookupIdent IR.ValueScope conName - Just conType' <- inEnv $ lookupReturnType IR.ValueScope conName - conType <- convertType' conType' - fConType <- convertType conType' - fArgTypes <- mapM convertType argTypes - (argIdents, argBinders) <- mapAndUnzipM convertAnonymousArg - (map Just argTypes) - let - -- We need an induction hypothesis for every argument that has the same - -- type as the constructor but lifted into the free monad. - addHypotheses' :: [(Coq.Term, Coq.Qualid)] -> Coq.Term -> Coq.Term - addHypotheses' [] = id - addHypotheses' ((argType, argIdent) : args) - | argType == fConType = Coq.Arrow - (genericForFree conType pIdent argIdent) - . addHypotheses' args - addHypotheses' (_ : args) = addHypotheses' args - addHypotheses = addHypotheses' (zip fArgTypes argIdents) - -- Create induction case. - term = addHypotheses - (Coq.app (Coq.Qualid pIdent) - [Coq.app (Coq.Qualid conIdent) (map Coq.Qualid argIdents)]) - indCase = if null argBinders - then term - else Coq.Forall (NonEmpty.fromList argBinders) term - indCaseIdent <- freshCoqQualid freshArgPrefix - indCaseBinder <- generateArgBinder indCaseIdent (Just indCase) - return (indCaseIdent, indCaseBinder) + let conName = IR.declIdentName declIdent + Just conIdent <- inEnv $ lookupIdent IR.ValueScope conName + Just conType' <- inEnv $ lookupReturnType IR.ValueScope conName + conType <- convertType' conType' + fConType <- convertType conType' + fArgTypes <- mapM convertType argTypes + (argIdents, argBinders) <- mapAndUnzipM convertAnonymousArg + (map Just argTypes) + let + -- We need an induction hypothesis for every argument that has the same + -- type as the constructor but lifted into the free monad. + addHypotheses' :: [(Coq.Term, Coq.Qualid)] -> Coq.Term -> Coq.Term + addHypotheses' [] = id + addHypotheses' ((argType, argIdent) : args) + | argType == fConType = Coq.Arrow (genericForFree conType pIdent argIdent) + . addHypotheses' args + addHypotheses' (_ : args) = addHypotheses' args + addHypotheses = addHypotheses' (zip fArgTypes argIdents) + -- Create induction case. + term = addHypotheses + (Coq.app (Coq.Qualid pIdent) + [Coq.app (Coq.Qualid conIdent) (map Coq.Qualid argIdents)]) + indCase = if null argBinders + then term + else Coq.Forall (NonEmpty.fromList argBinders) term + indCaseIdent <- freshCoqQualid freshArgPrefix + indCaseBinder <- generateArgBinder indCaseIdent (Just indCase) + return (indCaseIdent, indCaseBinder) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs index c1b58ced..d42e5afa 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs @@ -99,8 +99,6 @@ -- In this case, a type @T'@ is considered indirectly recursive if it -- contains any of the types @T₁, …, Tₙ@. -- Arguments of type @Tᵢ@ can be treated like directly recursive arguments. - - module FreeC.Backend.Coq.Converter.TypeDecl.TypeclassInstances where import Control.Monad @@ -129,7 +127,6 @@ import FreeC.Pretty ------------------------------------------------------------------------------- -- Instance Generation -- ------------------------------------------------------------------------------- - -- | Type synonym for a map mapping types to function names. type TypeMap = Map.Map IR.Type Coq.Qualid From 8b73979f3358123e6fe36de02c96eeb1a1cc0a18 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 20 Sep 2020 13:23:38 +0200 Subject: [PATCH 080/120] Test unformatted as-pattern #150 --- src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 9f2f3891..323a071b 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -152,8 +152,7 @@ convertDataDecls dataDecls = do -- not visible outside of this function. convertDataDecl :: IR.TypeDecl -> Converter (Coq.IndBody, ([Coq.Sentence], [Coq.Sentence])) -convertDataDecl dataDecl - @(IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do +convertDataDecl dataDecl@(IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do (body, argumentsSentences) <- generateBodyAndArguments (smartConDecls, qualSmartConDecls) <- concatUnzip <$> mapM generateSmartConDecl conDecls From 2aba14ba549f017913bfaae67e448641db903327 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 20 Sep 2020 13:35:48 +0200 Subject: [PATCH 081/120] Try workaround without as-pattern #150 --- src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 323a071b..0f8da1fa 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -152,11 +152,13 @@ convertDataDecls dataDecls = do -- not visible outside of this function. convertDataDecl :: IR.TypeDecl -> Converter (Coq.IndBody, ([Coq.Sentence], [Coq.Sentence])) -convertDataDecl dataDecl@(IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do +convertDataDecl + (IR.DataDecl srcSpan (IR.DeclIdent srcSpan' name) typeVarDecls conDecls) = do (body, argumentsSentences) <- generateBodyAndArguments (smartConDecls, qualSmartConDecls) <- concatUnzip <$> mapM generateSmartConDecl conDecls - inductionScheme <- generateInductionScheme dataDecl + inductionScheme <- generateInductionScheme + (IR.DataDecl srcSpan (IR.DeclIdent srcSpan' name) typeVarDecls conDecls) return ( body , ( Coq.commentedSentences ("Arguments sentences for " ++ showPretty (IR.toUnQual name)) From b3f257a610ab8500242f08549a918c5fab6a227e Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 20 Sep 2020 13:41:01 +0200 Subject: [PATCH 082/120] Rename source span variables #150 --- src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 0f8da1fa..2bd02bf4 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -153,7 +153,8 @@ convertDataDecls dataDecls = do convertDataDecl :: IR.TypeDecl -> Converter (Coq.IndBody, ([Coq.Sentence], [Coq.Sentence])) convertDataDecl - (IR.DataDecl srcSpan (IR.DeclIdent srcSpan' name) typeVarDecls conDecls) = do + (IR.DataDecl srcSpan' (IR.DeclIdent srcSpan'' name) typeVarDecls conDecls) + = do (body, argumentsSentences) <- generateBodyAndArguments (smartConDecls, qualSmartConDecls) <- concatUnzip <$> mapM generateSmartConDecl conDecls From 4a25f3b3f61c2b91d54a55d2b7d0f76631d61f42 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 20 Sep 2020 13:45:41 +0200 Subject: [PATCH 083/120] Also rename occurrences of the source span variables #150 --- src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 2bd02bf4..e6957678 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -159,7 +159,7 @@ convertDataDecl (smartConDecls, qualSmartConDecls) <- concatUnzip <$> mapM generateSmartConDecl conDecls inductionScheme <- generateInductionScheme - (IR.DataDecl srcSpan (IR.DeclIdent srcSpan' name) typeVarDecls conDecls) + (IR.DataDecl srcSpan' (IR.DeclIdent srcSpan'' name) typeVarDecls conDecls) return ( body , ( Coq.commentedSentences ("Arguments sentences for " ++ showPretty (IR.toUnQual name)) From b4f9edb675c100d238c8a0ff0117bb09a192d592 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 20 Sep 2020 13:50:40 +0200 Subject: [PATCH 084/120] Change Floskell configuration so as-patterns are not split #150 --- floskell.json | 5 +++++ src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs | 6 ++---- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/floskell.json b/floskell.json index bbd571f0..41d8b9ef 100644 --- a/floskell.json +++ b/floskell.json @@ -108,6 +108,11 @@ "force-linebreak": false, "spaces": "both", "linebreaks": "after" + }, + "@ in pattern": { + "force-linebreak": false, + "spaces": "none", + "linebreaks": "none" } }, "options": { diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index e6957678..3653b45b 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -153,13 +153,11 @@ convertDataDecls dataDecls = do convertDataDecl :: IR.TypeDecl -> Converter (Coq.IndBody, ([Coq.Sentence], [Coq.Sentence])) convertDataDecl - (IR.DataDecl srcSpan' (IR.DeclIdent srcSpan'' name) typeVarDecls conDecls) - = do + dataDecl@(IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do (body, argumentsSentences) <- generateBodyAndArguments (smartConDecls, qualSmartConDecls) <- concatUnzip <$> mapM generateSmartConDecl conDecls - inductionScheme <- generateInductionScheme - (IR.DataDecl srcSpan' (IR.DeclIdent srcSpan'' name) typeVarDecls conDecls) + inductionScheme <- generateInductionScheme dataDecl return ( body , ( Coq.commentedSentences ("Arguments sentences for " ++ showPretty (IR.toUnQual name)) From 733079b430ca4edf6c893293e4e4c20e62dce312 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 20 Sep 2020 13:56:03 +0200 Subject: [PATCH 085/120] Capitalize words in header comments #150 --- .../Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs index d42e5afa..9b716890 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs @@ -347,7 +347,7 @@ generateTypeclassInstances dataDecls = do return $ Coq.equation lhs rhs ------------------------------------------------------------------------------- - -- Functions to produce @Normalform@ instances -- + -- Functions to Produce @Normalform@ Instances -- ------------------------------------------------------------------------------- -- | The binders and return types for the @Normalform@ class function and instance. nfBindersAndReturnType @@ -434,7 +434,7 @@ generateTypeclassInstances dataDecls = do c ------------------------------------------------------------------------------- - -- Functions to produce @ShareableArgs@ instances -- + -- Functions to Produce @ShareableArgs@ Instances -- ------------------------------------------------------------------------------- -- | The binders and return types for the @ShareableArgs@ class function and instance. shareArgsBindersAndReturnType @@ -494,7 +494,7 @@ generateTypeclassInstances dataDecls = do (Coq.fun [sx] [Nothing] rhs) ------------------------------------------------------------------------------- - -- Helper functions -- + -- Helper Functions -- ------------------------------------------------------------------------------- -- | Creates an entry with a unique name for each of the given types and -- inserts them into the given map. From d46fa56980514cb6a9becc10687634c1182a5497 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Sun, 20 Sep 2020 13:58:29 +0200 Subject: [PATCH 086/120] Update Floskell configuration The Floskell configuration in the guidelines repository has been updated such that no whitespace is inserted around `@`-signs in as-patterns because HLint has truble parsing the patterns otherwise. --- floskell.json | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/floskell.json b/floskell.json index bbd571f0..41d8b9ef 100644 --- a/floskell.json +++ b/floskell.json @@ -108,6 +108,11 @@ "force-linebreak": false, "spaces": "both", "linebreaks": "after" + }, + "@ in pattern": { + "force-linebreak": false, + "spaces": "none", + "linebreaks": "none" } }, "options": { From 91328dfc04f6dd24ee43cff550b1a3d112c6ec73 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 20 Sep 2020 15:44:08 +0200 Subject: [PATCH 087/120] Format TypeDecl tests #150 --- .../Backend/Coq/Converter/TypeDeclTests.hs | 524 ++++++++++-------- 1 file changed, 289 insertions(+), 235 deletions(-) diff --git a/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs b/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs index 3943980a..1db65e74 100644 --- a/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs +++ b/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs @@ -114,63 +114,75 @@ testConvertTypeDecl ++ " (@pure Shape Pos (Tree Shape Pos a) (@branch Shape Pos a x))" ++ " ( only parsing, at level 10, Shape, Pos, a, x at level 9 ). " ++ " (* Normalform instance for Tree *) " - ++ "Fixpoint nf'Tree_ {Shape : Type} {Pos : Shape -> Type} " - ++ "{a b : Type} `{Normalform Shape Pos a b} " - ++ "(x : Tree Shape Pos a) " - ++ ": Free Shape Pos (Tree Identity.Shape Identity.Pos b) " - ++ ":= let fix nf'ListTree_ {a0 b0 : Type} " - ++ "`{Normalform Shape Pos a0 b0} " - ++ "(x1 : List Shape Pos (Tree Shape Pos a0)) " - ++ ": Free Shape Pos (List Identity.Shape Identity.Pos " - ++ "(Tree Identity.Shape Identity.Pos b0)) := match x1 with " - ++ "| nil => pure nil " - ++ "| cons fx1 fx2 => fx1 >>= (fun x2 => " - ++ "nf'Tree_ x2 >>= (fun nx1 => " - ++ "fx2 >>= (fun x3 => nf'ListTree_ x3 >>= (fun nx2 => " - ++ "pure (cons (pure nx1) (pure nx2)))))) " - ++ "end " - ++ "in match x with " - ++ "| leaf fx => nf fx >>= (fun nx => pure (leaf (pure nx))) " - ++ "| branch fx0 => fx0 >>= (fun x0 => " - ++ "nf'ListTree_ x0 >>= (fun nx0 => pure (branch (pure nx0)))) " - ++ "end. " - ++ "Instance NormalformTree_ {Shape : Type} {Pos : Shape -> Type} " - ++ "{a b : Type} `{Normalform Shape Pos a b} " - ++ ": Normalform Shape Pos (Tree Shape Pos a) " - ++ "(Tree Identity.Shape Identity.Pos b) := { nf' := nf'Tree_ }. " + ++ "Fixpoint nf'Tree_" + ++ " {Shape : Type} {Pos : Shape -> Type} " + ++ " {a b : Type} `{Normalform Shape Pos a b} " + ++ " (x : Tree Shape Pos a) " + ++ " : Free Shape Pos (Tree Identity.Shape Identity.Pos b) " + ++ " := let fix nf'ListTree_" + ++ " {a0 b0 : Type} `{Normalform Shape Pos a0 b0} " + ++ " (x1 : List Shape Pos (Tree Shape Pos a0)) " + ++ " : Free Shape Pos (List Identity.Shape Identity.Pos " + ++ " (Tree Identity.Shape Identity.Pos b0))" + ++ " := match x1 with " + ++ " | nil => pure nil " + ++ " | cons fx1 fx2 =>" + ++ " fx1 >>= (fun x2 =>" + ++ " nf'Tree_ x2 >>= (fun nx1 =>" + ++ " fx2 >>= (fun x3 =>" + ++ " nf'ListTree_ x3 >>= (fun nx2 =>" + ++ " pure (cons (pure nx1) (pure nx2))))))" + ++ " end " + ++ " in match x with " + ++ " | leaf fx => nf fx >>= (fun nx =>" + ++ " pure (leaf (pure nx)))" + ++ " | branch fx0 => fx0 >>= (fun x0 => " + ++ " nf'ListTree_ x0 >>= (fun nx0 =>" + ++ " pure (branch (pure nx0))))" + ++ " end. " + ++ "Instance NormalformTree_" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " {a b : Type} `{Normalform Shape Pos a b}" + ++ " : Normalform Shape Pos (Tree Shape Pos a)" + ++ " (Tree Identity.Shape Identity.Pos b)" + ++ " := { nf' := nf'Tree_ }. " ++ "(* ShareableArgs instance for Tree *) " - ++ "Fixpoint shareArgsTree_ {Shape : Type} {Pos : Shape -> Type} " - ++ "{a : Type} `{Injectable Share.Shape Share.Pos Shape Pos} " - ++ "`{ShareableArgs Shape Pos a} (x : Tree Shape Pos a) " - ++ ": Free Shape Pos (Tree Shape Pos a) " - ++ ":= let fix shareArgsListTree_ {a0 : Type} " - ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " - ++ "`{ShareableArgs Shape Pos a0} " - ++ "(x0 : List Shape Pos (Tree Shape Pos a0)) " - ++ ": Free Shape Pos (List Shape Pos (Tree Shape Pos a0)) " - ++ ":= match x0 with " - ++ "| nil => pure nil " - ++ "| cons fx1 fx2 => " - ++ "cbneed Shape Pos shareArgsTree_ fx1 >>= (fun sx1 => " - ++ "cbneed Shape Pos shareArgsListTree_ fx2 >>= (fun sx2 => " - ++ "pure (cons sx1 sx2))) " - ++ "end " - ++ "in match x with " - ++ "| leaf fx => cbneed Shape Pos shareArgs fx >>= (fun sx => " - ++ "pure (leaf sx)) " - ++ "| branch fx0 => " - ++ "cbneed Shape Pos shareArgsListTree_ fx0 >>= (fun sx0 => " - ++ "pure (branch sx0)) " - ++ "end. " - ++ "Instance ShareableArgsTree_ {Shape : Type} " - ++ "{Pos : Shape -> Type} {a : Type} " - ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " - ++ "`{ShareableArgs Shape Pos a} " - ++ ": ShareableArgs Shape Pos (Tree Shape Pos a) " - ++ ":= { shareArgs := shareArgsTree_ }. " - ++ "Definition Forest (Shape : Type) (Pos : Shape -> Type)" - ++ " (a : Type)" - ++ " : Type" + ++ "Fixpoint shareArgsTree_" + ++ " {Shape : Type} {Pos : Shape -> Type} " + ++ " {a : Type} `{Injectable Share.Shape Share.Pos Shape Pos}" + ++ " `{ShareableArgs Shape Pos a} (x : Tree Shape Pos a) " + ++ " : Free Shape Pos (Tree Shape Pos a) " + ++ " := let fix shareArgsListTree_" + ++ " {a0 : Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" + ++ " `{ShareableArgs Shape Pos a0}" + ++ " (x0 : List Shape Pos (Tree Shape Pos a0))" + ++ " : Free Shape Pos (List Shape Pos (Tree Shape Pos a0))" + ++ " := match x0 with " + ++ " | nil => pure nil " + ++ " | cons fx1 fx2 => " + ++ " cbneed Shape Pos shareArgsTree_ fx1 >>= (fun sx1 =>" + ++ " cbneed Shape Pos shareArgsListTree_ fx2 >>=" + ++ " (fun sx2 => " + ++ " pure (cons sx1 sx2))) " + ++ " end " + ++ " in match x with " + ++ " | leaf fx => cbneed Shape Pos shareArgs fx >>= (fun sx =>" + ++ " pure (leaf sx)) " + ++ " | branch fx0 => " + ++ " cbneed Shape Pos shareArgsListTree_ fx0 >>=" + ++ " (fun sx0 =>" + ++ " pure (branch sx0)) " + ++ " end. " + ++ "Instance ShareableArgsTree_" + ++ " {Shape : Type} {Pos : Shape -> Type} {a : Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos} " + ++ " `{ShareableArgs Shape Pos a} " + ++ " : ShareableArgs Shape Pos (Tree Shape Pos a) " + ++ " := { shareArgs := shareArgsTree_ }. " + ++ "Definition Forest" + ++ " (Shape : Type) (Pos : Shape -> Type) (a : Type)" + ++ " : Type" ++ " := List Shape Pos (Tree Shape Pos a)." it "sorts type synonym declarations topologically" $ shouldSucceedWith $ do "Bar" <- defineTestTypeSyn "Bar" [] "Baz" @@ -206,27 +218,36 @@ testConvertTypeDecl ++ " (@pure Shape Pos (Foo Shape Pos) (@foo Shape Pos x x0))" ++ " ( only parsing, at level 10, Shape, Pos, x, x0 at level 9 ). " ++ " (* Normalform instance for Foo *) " - ++ "Fixpoint nf'Foo {Shape : Type} {Pos : Shape -> Type} " - ++ "(x : Foo Shape Pos) " - ++ ": Free Shape Pos (Foo Identity.Shape Identity.Pos) " - ++ ":= let 'foo fx fx0 := x in fx >>= (fun x0 => " - ++ "nf'Foo x0 >>= (fun nx => " - ++ "fx0 >>= (fun x1 => nf'Foo x1 >>= (fun nx0 => " - ++ "pure (foo (pure nx) (pure nx0)))))). " - ++ "Instance NormalformFoo {Shape : Type} {Pos : Shape -> Type} " - ++ ": Normalform Shape Pos (Foo Shape Pos) " - ++ "(Foo Identity.Shape Identity.Pos) := { nf' := nf'Foo }. " + ++ "Fixpoint nf'Foo" + ++ " {Shape : Type} {Pos : Shape -> Type} " + ++ " (x : Foo Shape Pos) " + ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos) " + ++ " := let 'foo fx fx0 := x" + ++ " in fx >>= (fun x0 =>" + ++ " nf'Foo x0 >>= (fun nx =>" + ++ " fx0 >>= (fun x1 =>" + ++ " nf'Foo x1 >>= (fun nx0 =>" + ++ " pure (foo (pure nx) (pure nx0)))))). " + ++ "Instance NormalformFoo" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " : Normalform Shape Pos (Foo Shape Pos)" + ++ " (Foo Identity.Shape Identity.Pos)" + ++ " := { nf' := nf'Foo }. " ++ "(* ShareableArgs instance for Foo *) " - ++ "Fixpoint shareArgsFoo {Shape : Type} {Pos : Shape -> Type} " - ++ "`{Injectable Share.Shape Share.Pos Shape Pos} (x : Foo Shape Pos) " - ++ ": Free Shape Pos (Foo Shape Pos) := let 'foo fx fx0 := x " - ++ "in cbneed Shape Pos shareArgsFoo fx >>= (fun sx => " - ++ "cbneed Shape Pos shareArgsFoo fx0 >>= (fun sx0 => " - ++ "pure (foo sx sx0))). " - ++ "Instance ShareableArgsFoo {Shape : Type} {Pos : Shape -> Type} " - ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " - ++ ": ShareableArgs Shape Pos (Foo Shape Pos) " - ++ ":= { shareArgs := shareArgsFoo }. " + ++ "Fixpoint shareArgsFoo" + ++ " {Shape : Type} {Pos : Shape -> Type} " + ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" + ++ " (x : Foo Shape Pos) " + ++ " : Free Shape Pos (Foo Shape Pos)" + ++ " := let 'foo fx fx0 := x" + ++ " in cbneed Shape Pos shareArgsFoo fx >>= (fun sx =>" + ++ " cbneed Shape Pos shareArgsFoo fx0 >>= (fun sx0 =>" + ++ " pure (foo sx sx0))). " + ++ "Instance ShareableArgsFoo" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" + ++ " : ShareableArgs Shape Pos (Foo Shape Pos)" + ++ " := { shareArgs := shareArgsFoo }. " ++ "Definition Baz (Shape : Type) (Pos : Shape -> Type)" ++ " : Type" ++ " := Foo Shape Pos. " @@ -284,29 +305,33 @@ testConvertDataDecls ++ " (@pure Shape Pos (Foo Shape Pos) (@baz Shape Pos))" ++ " ( only parsing, at level 10, Shape, Pos at level 9 ). " ++ "(* Normalform instance for Foo *) " - ++ "Fixpoint nf'Foo {Shape : Type} {Pos : Shape -> Type} " - ++ "(x : Foo Shape Pos) " - ++ ": Free Shape Pos (Foo Identity.Shape Identity.Pos) " - ++ ":= match x with " - ++ "| bar => pure bar " - ++ "| baz => pure baz " - ++ "end. " - ++ "Instance NormalformFoo {Shape : Type} {Pos : Shape -> Type} " - ++ ": Normalform Shape Pos (Foo Shape Pos) " - ++ "(Foo Identity.Shape Identity.Pos) := { nf' := nf'Foo }. " + ++ "Fixpoint nf'Foo" + ++ " {Shape : Type} {Pos : Shape -> Type} (x : Foo Shape Pos)" + ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos)" + ++ " := match x with" + ++ " | bar => pure bar" + ++ " | baz => pure baz" + ++ " end. " + ++ "Instance NormalformFoo" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " : Normalform Shape Pos (Foo Shape Pos)" + ++ " (Foo Identity.Shape Identity.Pos)" + ++ " := { nf' := nf'Foo }. " ++ "(* ShareableArgs instance for Foo *) " - ++ "Fixpoint shareArgsFoo {Shape : Type} {Pos : Shape -> Type} " - ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " - ++ "(x : Foo Shape Pos) : Free Shape Pos (Foo Shape Pos) " - ++ ":= match x with " - ++ "| bar => pure bar " - ++ "| baz => pure baz " - ++ "end. " - ++ "Instance ShareableArgsFoo {Shape : Type} " - ++ "{Pos : Shape -> Type} " - ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " - ++ ": ShareableArgs Shape Pos (Foo Shape Pos) " - ++ ":= { shareArgs := shareArgsFoo }. " + ++ "Fixpoint shareArgsFoo" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" + ++ " (x : Foo Shape Pos)" + ++ " : Free Shape Pos (Foo Shape Pos)" + ++ " := match x with" + ++ " | bar => pure bar" + ++ " | baz => pure baz" + ++ " end. " + ++ "Instance ShareableArgsFoo" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" + ++ " : ShareableArgs Shape Pos (Foo Shape Pos) " + ++ " := { shareArgs := shareArgsFoo }. " it "translates polymorphic data types correctly" $ shouldSucceedWith $ do "Foo" <- defineTestTypeCon "Foo" 2 ["Bar", "Baz"] ("bar", "Bar") <- defineTestCon "Bar" 1 "forall a b. a -> Foo a b" @@ -343,40 +368,41 @@ testConvertDataDecls ++ " (@pure Shape Pos (Foo Shape Pos a b) (@baz Shape Pos a b x))" ++ " ( only parsing, at level 10, Shape, Pos, a, b, x at level 9 ). " ++ "(* Normalform instance for Foo *) " - ++ "Fixpoint nf'Foo__ {Shape : Type} {Pos : Shape -> Type} " - ++ "{a a0 b b0 : Type} `{Normalform Shape Pos a b} " - ++ "`{Normalform Shape Pos a0 b0} (x : Foo Shape Pos a a0) " - ++ ": Free Shape Pos (Foo Identity.Shape Identity.Pos b b0) " - ++ ":= match x with " - ++ "| bar fx => nf fx >>= " - ++ "(fun nx => pure (bar (pure nx))) " - ++ "| baz fx0 => " - ++ "nf fx0 >>= (fun nx0 => pure (baz (pure nx0))) " - ++ "end. " - ++ "Instance NormalformFoo__ {Shape : Type} {Pos : Shape -> Type} " - ++ "{a a0 b b0 : Type} `{Normalform Shape Pos a b} " - ++ "`{Normalform Shape Pos a0 b0} " - ++ ": Normalform Shape Pos (Foo Shape Pos a a0) " - ++ "(Foo Identity.Shape Identity.Pos b b0) " - ++ ":= { nf' := nf'Foo__ }. " + ++ "Fixpoint nf'Foo__" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " {a a0 b b0 : Type} `{Normalform Shape Pos a b}" + ++ " `{Normalform Shape Pos a0 b0} (x : Foo Shape Pos a a0)" + ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos b b0)" + ++ " := match x with" + ++ " | bar fx => nf fx >>= (fun nx => pure (bar (pure nx)))" + ++ " | baz fx0 => nf fx0 >>= (fun nx0 => pure (baz (pure nx0)))" + ++ " end. " + ++ "Instance NormalformFoo__" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " {a a0 b b0 : Type} `{Normalform Shape Pos a b}" + ++ " `{Normalform Shape Pos a0 b0}" + ++ " : Normalform Shape Pos (Foo Shape Pos a a0)" + ++ " (Foo Identity.Shape Identity.Pos b b0)" + ++ " := { nf' := nf'Foo__ }. " ++ "(* ShareableArgs instance for Foo *) " - ++ "Fixpoint shareArgsFoo__ {Shape : Type} " - ++ "{Pos : Shape -> Type} {a a0 : Type} " - ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " - ++ "`{ShareableArgs Shape Pos a} `{ShareableArgs Shape Pos a0} " - ++ "(x : Foo Shape Pos a a0) : Free Shape Pos (Foo Shape Pos a a0) " - ++ ":= match x with " - ++ "| bar fx => cbneed Shape Pos shareArgs fx >>= (fun sx => " - ++ "pure (bar sx)) " - ++ "| baz fx0 => cbneed Shape Pos shareArgs fx0 >>= (fun sx0 => " - ++ "pure (baz sx0)) " - ++ "end. " - ++ "Instance ShareableArgsFoo__ {Shape : Type} " - ++ "{Pos : Shape -> Type} {a a0 : Type} " - ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " - ++ "`{ShareableArgs Shape Pos a} `{ShareableArgs Shape Pos a0} " - ++ ": ShareableArgs Shape Pos (Foo Shape Pos a a0) " - ++ ":= { shareArgs := shareArgsFoo__ }. " + ++ "Fixpoint shareArgsFoo__" + ++ " {Shape : Type} {Pos : Shape -> Type} {a a0 : Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos} " + ++ " `{ShareableArgs Shape Pos a} `{ShareableArgs Shape Pos a0}" + ++ " (x : Foo Shape Pos a a0)" + ++ " : Free Shape Pos (Foo Shape Pos a a0)" + ++ " := match x with" + ++ " | bar fx => cbneed Shape Pos shareArgs fx >>= (fun sx =>" + ++ " pure (bar sx))" + ++ " | baz fx0 => cbneed Shape Pos shareArgs fx0 >>= (fun sx0 =>" + ++ " pure (baz sx0))" + ++ " end. " + ++ "Instance ShareableArgsFoo__" + ++ " {Shape : Type} {Pos : Shape -> Type} {a a0 : Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" + ++ " `{ShareableArgs Shape Pos a} `{ShareableArgs Shape Pos a0}" + ++ " : ShareableArgs Shape Pos (Foo Shape Pos a a0)" + ++ " := { shareArgs := shareArgsFoo__ }. " it "renames constructors with same name as their data type" $ shouldSucceedWith $ do @@ -402,24 +428,27 @@ testConvertDataDecls ++ " (@pure Shape Pos (Foo Shape Pos) (@foo Shape Pos))" ++ " ( only parsing, at level 10, Shape, Pos at level 9 ). " ++ "(* Normalform instance for Foo *) " - ++ "Fixpoint nf'Foo {Shape : Type} {Pos : Shape -> Type} " - ++ "(x : Foo Shape Pos) " - ++ ": Free Shape Pos (Foo Identity.Shape Identity.Pos) " - ++ ":= let 'foo := x in pure foo. " - ++ "Instance NormalformFoo {Shape : Type} {Pos : Shape -> Type} " - ++ ": Normalform Shape Pos (Foo Shape Pos) " - ++ "(Foo Identity.Shape Identity.Pos) " - ++ ":= { nf' := nf'Foo }. " + ++ "Fixpoint nf'Foo" + ++ " {Shape : Type} {Pos : Shape -> Type} (x : Foo Shape Pos)" + ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos) " + ++ " := let 'foo := x in pure foo. " + ++ "Instance NormalformFoo" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " : Normalform Shape Pos (Foo Shape Pos)" + ++ " (Foo Identity.Shape Identity.Pos)" + ++ " := { nf' := nf'Foo }. " ++ "(* ShareableArgs instance for Foo *) " - ++ "Fixpoint shareArgsFoo {Shape : Type} {Pos : Shape -> Type} " - ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " - ++ "(x : Foo Shape Pos) : Free Shape Pos (Foo Shape Pos) " - ++ ":= let 'foo := x in pure foo. " - ++ "Instance ShareableArgsFoo {Shape : Type} " - ++ "{Pos : Shape -> Type} " - ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " - ++ ": ShareableArgs Shape Pos (Foo Shape Pos) " - ++ ":= { shareArgs := shareArgsFoo }. " + ++ "Fixpoint shareArgsFoo" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" + ++ " (x : Foo Shape Pos)" + ++ " : Free Shape Pos (Foo Shape Pos)" + ++ " := let 'foo := x in pure foo. " + ++ "Instance ShareableArgsFoo" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" + ++ " : ShareableArgs Shape Pos (Foo Shape Pos)" + ++ " := { shareArgs := shareArgsFoo }. " it "renames type variables with same name as generated constructors" $ shouldSucceedWith $ do @@ -447,29 +476,34 @@ testConvertDataDecls ++ " (@pure Shape Pos (Foo Shape Pos a0) (@a Shape Pos a0 x))" ++ " ( only parsing, at level 10, Shape, Pos, a0, x at level 9 ). " ++ "(* Normalform instance for Foo *) " - ++ "Fixpoint nf'Foo_ {Shape : Type} {Pos : Shape -> Type} " - ++ "{a0 b : Type} `{Normalform Shape Pos a0 b} " - ++ "(x : Foo Shape Pos a0) " - ++ ": Free Shape Pos (Foo Identity.Shape Identity.Pos b) " - ++ ":= let 'a fx := x " - ++ "in nf fx >>= (fun nx => pure (a (pure nx))). " - ++ "Instance NormalformFoo_ {Shape : Type} {Pos : Shape -> Type} " - ++ "{a0 b : Type} `{Normalform Shape Pos a0 b} " - ++ ": Normalform Shape Pos (Foo Shape Pos a0) " - ++ "(Foo Identity.Shape Identity.Pos b) " - ++ ":= { nf' := nf'Foo_ }. " + ++ "Fixpoint nf'Foo_" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " {a0 b : Type} `{Normalform Shape Pos a0 b}" + ++ " (x : Foo Shape Pos a0)" + ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos b)" + ++ " := let 'a fx := x" + ++ " in nf fx >>= (fun nx => pure (a (pure nx))). " + ++ "Instance NormalformFoo_" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " {a0 b : Type} `{Normalform Shape Pos a0 b}" + ++ " : Normalform Shape Pos (Foo Shape Pos a0)" + ++ " (Foo Identity.Shape Identity.Pos b)" + ++ " := { nf' := nf'Foo_ }. " ++ "(* ShareableArgs instance for Foo *) " - ++ "Fixpoint shareArgsFoo_ {Shape : Type} {Pos : Shape -> Type} " - ++ "{a0 : Type} `{Injectable Share.Shape Share.Pos Shape Pos} " - ++ "`{ShareableArgs Shape Pos a0} (x : Foo Shape Pos a0) " - ++ ": Free Shape Pos (Foo Shape Pos a0) := let 'a fx := x in " - ++ "cbneed Shape Pos shareArgs fx >>= (fun sx => pure (a sx)). " - ++ "Instance ShareableArgsFoo_ {Shape : Type} " - ++ "{Pos : Shape -> Type} {a0 : Type} " - ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " - ++ "`{ShareableArgs Shape Pos a0} " - ++ ": ShareableArgs Shape Pos (Foo Shape Pos a0) " - ++ ":= { shareArgs := shareArgsFoo_ }." + ++ "Fixpoint shareArgsFoo_" + ++ " {Shape : Type} {Pos : Shape -> Type} {a0 : Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos} " + ++ " `{ShareableArgs Shape Pos a0} (x : Foo Shape Pos a0) " + ++ " : Free Shape Pos (Foo Shape Pos a0)" + ++ " := let 'a fx := x" + ++ " in cbneed Shape Pos shareArgs fx >>= (fun sx =>" + ++ " pure (a sx)). " + ++ "Instance ShareableArgsFoo_" + ++ " {Shape : Type} {Pos : Shape -> Type} {a0 : Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" + ++ " `{ShareableArgs Shape Pos a0}" + ++ " : ShareableArgs Shape Pos (Foo Shape Pos a0)" + ++ " := { shareArgs := shareArgsFoo_ }." it "translates mutually recursive data types correctly" $ shouldSucceedWith $ do @@ -515,45 +549,58 @@ testConvertDataDecls ++ " (@pure Shape Pos (Bar Shape Pos) (@bar Shape Pos x))" ++ " ( only parsing, at level 10, Shape, Pos, x at level 9 ). " ++ "(* Normalform instances for Foo, Bar *) " - ++ "Fixpoint nf'Foo {Shape : Type} {Pos : Shape -> Type} " - ++ "(x : Foo Shape Pos) " - ++ ": Free Shape Pos (Foo Identity.Shape Identity.Pos) " - ++ ":= let 'foo fx := x in fx >>= (fun x0 => " - ++ "nf'Bar x0 >>= (fun nx => pure (foo (pure nx)))) " - ++ "with nf'Bar {Shape : Type} {Pos : Shape -> Type} " - ++ "(x : Bar Shape Pos) " - ++ ": Free Shape Pos (Bar Identity.Shape Identity.Pos) " - ++ ":= let 'bar fx := x in fx >>= (fun x0 => " - ++ "nf'Foo x0 >>= (fun nx => pure (bar (pure nx)))). " - ++ "Instance NormalformFoo {Shape : Type} {Pos : Shape -> Type} " - ++ ": Normalform Shape Pos (Foo Shape Pos) " - ++ "(Foo Identity.Shape Identity.Pos) := { nf' := nf'Foo }. " - ++ "Instance NormalformBar {Shape : Type} {Pos : Shape -> Type} " - ++ ": Normalform Shape Pos (Bar Shape Pos) " - ++ "(Bar Identity.Shape Identity.Pos) := { nf' := nf'Bar }. " + ++ "Fixpoint nf'Foo" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " (x : Foo Shape Pos)" + ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos)" + ++ " := let 'foo fx := x" + ++ " in fx >>= (fun x0 =>" + ++ " nf'Bar x0 >>= (fun nx => pure (foo (pure nx)))) " + ++ "with nf'Bar" + ++ " {Shape : Type} {Pos : Shape -> Type} (x : Bar Shape Pos)" + ++ " : Free Shape Pos (Bar Identity.Shape Identity.Pos)" + ++ " := let 'bar fx := x" + ++ " in fx >>= (fun x0 =>" + ++ " nf'Foo x0 >>= (fun nx =>" + ++ " pure (bar (pure nx)))). " + ++ "Instance NormalformFoo" + ++ " {Shape : Type} {Pos : Shape -> Type} " + ++ " : Normalform Shape Pos (Foo Shape Pos) " + ++ " (Foo Identity.Shape Identity.Pos)" + ++ " := { nf' := nf'Foo }. " + ++ "Instance NormalformBar" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " : Normalform Shape Pos (Bar Shape Pos)" + ++ " (Bar Identity.Shape Identity.Pos)" + ++ " := { nf' := nf'Bar }. " ++ "(* ShareableArgs instances for Foo, Bar *) " - ++ "Fixpoint shareArgsFoo {Shape : Type} {Pos : Shape -> Type} " - ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " - ++ "(x : Foo Shape Pos) " - ++ ": Free Shape Pos (Foo Shape Pos) := let 'foo fx := x in " - ++ "cbneed Shape Pos shareArgsBar fx >>= (fun sx => " - ++ "pure (foo sx)) with " - ++ "shareArgsBar {Shape : Type} {Pos : Shape -> Type} " - ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " - ++ "(x : Bar Shape Pos) : Free Shape Pos (Bar Shape Pos) " - ++ ":= let 'bar fx := x in " - ++ "cbneed Shape Pos shareArgsFoo fx >>= (fun sx => " - ++ "pure (bar sx)). " - ++ "Instance ShareableArgsFoo {Shape : Type} " - ++ "{Pos : Shape -> Type} " - ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " - ++ ": ShareableArgs Shape Pos (Foo Shape Pos) " - ++ ":= { shareArgs := shareArgsFoo }. " - ++ "Instance ShareableArgsBar {Shape : Type} " - ++ "{Pos : Shape -> Type} " - ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " - ++ ": ShareableArgs Shape Pos (Bar Shape Pos) " - ++ ":= { shareArgs := shareArgsBar }. " + ++ "Fixpoint shareArgsFoo" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" + ++ " (x : Foo Shape Pos) " + ++ " : Free Shape Pos (Foo Shape Pos)" + ++ " := let 'foo fx := x" + ++ " in cbneed Shape Pos shareArgsBar fx >>= (fun sx =>" + ++ " pure (foo sx)) " + ++ "with " + ++ "shareArgsBar" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" + ++ " (x : Bar Shape Pos)" + ++ " : Free Shape Pos (Bar Shape Pos)" + ++ " := let 'bar fx := x" + ++ " in cbneed Shape Pos shareArgsFoo fx >>= (fun sx =>" + ++ " pure (bar sx)). " + ++ "Instance ShareableArgsFoo" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" + ++ " : ShareableArgs Shape Pos (Foo Shape Pos)" + ++ " := { shareArgs := shareArgsFoo }. " + ++ "Instance ShareableArgsBar" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" + ++ " : ShareableArgs Shape Pos (Bar Shape Pos)" + ++ " := { shareArgs := shareArgsBar }. " context "Generation of induction schemes" $ do it "creates a correct induction scheme" $ shouldSucceedWith $ do "Foo" <- defineTestTypeCon "Foo" 1 ["Foo"] @@ -590,34 +637,41 @@ testConvertDataDecls ++ " (@pure Shape Pos (Foo Shape Pos a) (@foo Shape Pos a x x0 x1))" ++ " ( only parsing, at level 10, " ++ " Shape, Pos, a, x, x0, x1 at level 9 ). " - ++ " (* Normalform instance for Foo *) " - ++ "Fixpoint nf'Foo_ {Shape : Type} {Pos : Shape -> Type} " - ++ "{a b : Type} `{Normalform Shape Pos a b} (x : Foo Shape Pos a) " - ++ ": Free Shape Pos (Foo Identity.Shape Identity.Pos b) " - ++ ":= let 'foo fx fx0 fx1 := x in fx >>= (fun x0 => " - ++ "nf'Foo_ x0 >>= (fun nx => nf fx0 >>= (fun nx0 => " - ++ "fx1 >>= (fun x1 => nf'Foo_ x1 >>= (fun nx1 => " - ++ "pure (foo (pure nx) (pure nx0) (pure nx1))))))). " - ++ "Instance NormalformFoo_ {Shape : Type} {Pos : Shape -> Type} " - ++ "{a b : Type} `{Normalform Shape Pos a b} " - ++ ": Normalform Shape Pos (Foo Shape Pos a) " - ++ "(Foo Identity.Shape Identity.Pos b) " - ++ ":= { nf' := nf'Foo_ }. " + ++ "(* Normalform instance for Foo *) " + ++ "Fixpoint nf'Foo_" + ++ " {Shape : Type} {Pos : Shape -> Type} {a b : Type}" + ++ " `{Normalform Shape Pos a b} (x : Foo Shape Pos a) " + ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos b) " + ++ " := let 'foo fx fx0 fx1 := x" + ++ " in fx >>= (fun x0 => " + ++ " nf'Foo_ x0 >>= (fun nx =>" + ++ " nf fx0 >>= (fun nx0 =>" + ++ " fx1 >>= (fun x1 =>" + ++ " nf'Foo_ x1 >>= (fun nx1 =>" + ++ " pure (foo (pure nx) (pure nx0) (pure nx1))))))). " + ++ "Instance NormalformFoo_" + ++ " {Shape : Type} {Pos : Shape -> Type}" + ++ " {a b : Type} `{Normalform Shape Pos a b}" + ++ " : Normalform Shape Pos (Foo Shape Pos a)" + ++ " (Foo Identity.Shape Identity.Pos b)" + ++ " := { nf' := nf'Foo_ }. " ++ "(* ShareableArgs instance for Foo *) " - ++ "Fixpoint shareArgsFoo_ {Shape : Type} {Pos : Shape -> Type} " - ++ "{a : Type} `{Injectable Share.Shape Share.Pos Shape Pos} " - ++ "`{ShareableArgs Shape Pos a} (x : Foo Shape Pos a) " - ++ ": Free Shape Pos (Foo Shape Pos a) := let 'foo fx fx0 fx1 := x " - ++ "in cbneed Shape Pos shareArgsFoo_ fx >>= (fun sx => " - ++ "cbneed Shape Pos shareArgs fx0 >>= (fun sx0 => " - ++ "cbneed Shape Pos shareArgsFoo_ fx1 >>= (fun sx1 => " - ++ "pure (foo sx sx0 sx1)))). " - ++ "Instance ShareableArgsFoo_ {Shape : Type} " - ++ "{Pos : Shape -> Type} {a : Type} " - ++ "`{Injectable Share.Shape Share.Pos Shape Pos} " - ++ "`{ShareableArgs Shape Pos a} " - ++ ": ShareableArgs Shape Pos (Foo Shape Pos a) " - ++ ":= { shareArgs := shareArgsFoo_ }. " + ++ "Fixpoint shareArgsFoo_" + ++ " {Shape : Type} {Pos : Shape -> Type} {a : Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos} " + ++ " `{ShareableArgs Shape Pos a} (x : Foo Shape Pos a) " + ++ " : Free Shape Pos (Foo Shape Pos a)" + ++ " := let 'foo fx fx0 fx1 := x " + ++ " in cbneed Shape Pos shareArgsFoo_ fx >>= (fun sx =>" + ++ " cbneed Shape Pos shareArgs fx0 >>= (fun sx0 =>" + ++ " cbneed Shape Pos shareArgsFoo_ fx1 >>= (fun sx1 =>" + ++ " pure (foo sx sx0 sx1)))). " + ++ "Instance ShareableArgsFoo_" + ++ " {Shape : Type} {Pos : Shape -> Type} {a : Type}" + ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" + ++ " `{ShareableArgs Shape Pos a}" + ++ " : ShareableArgs Shape Pos (Foo Shape Pos a)" + ++ " := { shareArgs := shareArgsFoo_ }. " context "Generation of qualified smart constructor notations" $ do it "produces qualified notations for a single type correctly" $ shouldSucceedWith From f1f0e6cc93e669eb391331e0dbf6408036bc3d34 Mon Sep 17 00:00:00 2001 From: Daniel Teut Date: Mon, 21 Sep 2020 00:33:41 +0200 Subject: [PATCH 088/120] Apply suggestions from code review Co-authored-by: Justin Andresen --- src/lib/FreeC/LiftedIR/Converter/Expr.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/lib/FreeC/LiftedIR/Converter/Expr.hs b/src/lib/FreeC/LiftedIR/Converter/Expr.hs index 7674b015..24bc29c8 100644 --- a/src/lib/FreeC/LiftedIR/Converter/Expr.hs +++ b/src/lib/FreeC/LiftedIR/Converter/Expr.hs @@ -340,23 +340,23 @@ liftBinds ((IR.Bind srcSpan varPat bindExpr) : bs) expr = localEnv $ do varPat' <- makeVarPat patSrcSpan (IR.varPatQName varPat) patType' shareType' <- mapM LIR.liftType' varPatType bindExpr' <- liftExpr bindExpr - let countExprs = expr : map IR.bindExpr bs - shareOp - = if sum (map (countVarInExpr $ IR.varPatQName varPat) countExprs) > 1 - then LIR.Share - else LIR.Call + let varName = IR.varPatQName varPat + countExprs = expr : map IR.bindExpr bs + count = sum (map (countVarInExpr varName) countExprs) + shareOp | count > 1 = LIR.Share + | otherwise = LIR.Call shareExpr = shareOp srcSpan bindExpr' shareType' return $ LIR.Bind srcSpan shareExpr (LIR.Lambda srcSpan [varPat'] expr') -- | Counts the number of times the variable with the given qualified name -- occurs in the given expression. countVarInExpr :: IR.QName -> IR.Expr -> Int -countVarInExpr varPat = countVarInExpr' +countVarInExpr varName = countVarInExpr' where countVarInExpr' :: IR.Expr -> Int - countVarInExpr' IR.Con {} = 0 - countVarInExpr' (IR.Var _ varName _) - = if varPat == varName then 1 else 0 + countVarInExpr' IR.Con {} = 0 + countVarInExpr' (IR.Var _ varName' _) | varName == varName' = 1 + | otherwise = 0 countVarInExpr' (IR.App _ lhs rhs _) = countVarInExpr' lhs + countVarInExpr' rhs countVarInExpr' (IR.TypeAppExpr _ lhs _ _) = countVarInExpr' lhs @@ -378,5 +378,5 @@ countVarInExpr varPat = countVarInExpr' -- Returns @0@ if the variable occurs in the given variable patterns. countVarInBinds :: [IR.VarPat] -> IR.Expr -> Int countVarInBinds varPats exprs - | any (\varPat' -> IR.varPatQName varPat' == varPat) varPats = 0 + | varPat `elem` map IR.varPatQName varPats = 0 | otherwise = countVarInExpr varPat exprs From 28e224ef426e6a999628c292de0c1567a45d48fc Mon Sep 17 00:00:00 2001 From: Daniel Teut Date: Mon, 21 Sep 2020 00:42:07 +0200 Subject: [PATCH 089/120] Apply review suggestions #196 --- src/lib/FreeC/LiftedIR/Converter/Expr.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/lib/FreeC/LiftedIR/Converter/Expr.hs b/src/lib/FreeC/LiftedIR/Converter/Expr.hs index 24bc29c8..cf11803a 100644 --- a/src/lib/FreeC/LiftedIR/Converter/Expr.hs +++ b/src/lib/FreeC/LiftedIR/Converter/Expr.hs @@ -354,9 +354,9 @@ countVarInExpr :: IR.QName -> IR.Expr -> Int countVarInExpr varName = countVarInExpr' where countVarInExpr' :: IR.Expr -> Int - countVarInExpr' IR.Con {} = 0 - countVarInExpr' (IR.Var _ varName' _) | varName == varName' = 1 - | otherwise = 0 + countVarInExpr' IR.Con {} = 0 + countVarInExpr' (IR.Var _ varName' _) | varName == varName' = 1 + | otherwise = 0 countVarInExpr' (IR.App _ lhs rhs _) = countVarInExpr' lhs + countVarInExpr' rhs countVarInExpr' (IR.TypeAppExpr _ lhs _ _) = countVarInExpr' lhs @@ -377,6 +377,5 @@ countVarInExpr varName = countVarInExpr' -- -- Returns @0@ if the variable occurs in the given variable patterns. countVarInBinds :: [IR.VarPat] -> IR.Expr -> Int - countVarInBinds varPats exprs - | varPat `elem` map IR.varPatQName varPats = 0 - | otherwise = countVarInExpr varPat exprs + countVarInBinds varPats expr | varName `elem` map IR.varPatQName varPats = 0 + | otherwise = countVarInExpr' expr From 417a554851f72ec9d8024273e3442eadef7c6f9a Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Mon, 21 Sep 2020 23:41:58 +0200 Subject: [PATCH 090/120] Expose depth map creation functions from termination checker #209 Depth maps are used by the termination checker to keep track of the nesting depth of a variable within the structure of the decreasing argument. This information is also needed to fix bugs associated with the generation of helper functions for recursive functions in the presence of `let`-bindings. --- .../Coq/Analysis/DecreasingArguments.hs | 203 ++++++++++-------- src/lib/FreeC/IR/Subterm.hs | 16 +- 2 files changed, 129 insertions(+), 90 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Analysis/DecreasingArguments.hs b/src/lib/FreeC/Backend/Coq/Analysis/DecreasingArguments.hs index f9c3775c..13ffc7e1 100644 --- a/src/lib/FreeC/Backend/Coq/Analysis/DecreasingArguments.hs +++ b/src/lib/FreeC/Backend/Coq/Analysis/DecreasingArguments.hs @@ -67,7 +67,7 @@ -- * variables that are introduced by @let@-bindings are structually equal -- to their right-hand side. -- --- == Bypassing the termination checker +-- == Bypassing the Termination Checker -- -- Coq's termination checker uses the same idea as described above but -- is much more sophisticated. If the user knows that their function @@ -80,15 +80,20 @@ module FreeC.Backend.Coq.Analysis.DecreasingArguments ( DecArgIndex , identifyDecArgs + -- * Depth Map + , DepthMap + , depthMapAt ) where import Data.List ( find ) import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map +import Data.Maybe ( mapMaybe ) import qualified Data.Set as Set import Data.Tuple.Extra ( uncurry3 ) import FreeC.Environment +import FreeC.IR.Subterm import qualified FreeC.IR.Syntax as IR import FreeC.Monad.Converter import FreeC.Monad.Reporter @@ -158,115 +163,135 @@ checkDecArgs decls knownDecArgIndecies decArgIndecies = all checkDecArg (Just _) _ _ = True checkDecArg _ decArgIndex (IR.FuncDecl _ _ _ args _ rhs) = let decArg = IR.varPatQName (args !! decArgIndex) - in checkExpr (Map.singleton decArg 0) rhs [] + in checkExpr (Map.singleton decArg 0) rhs -- | Tests whether there is a variable that is structurally smaller than the - -- argument with the given name in the position of decreasing arguments of - -- all applications of functions from the strongly connected component. + -- potential decreasing argument in the position of the decreasing argumnet + -- for all applications of functions from the strongly connected component. -- -- The first argument maps variables that are known to be structurally -- smaller or equal than the decreasing argument of the function whose -- right-hand side is checked to their depth within the structure. The -- decreasing argument itself and its aliases have a depth of @0@. - -- - -- The last argument is a list of actual arguments passed to the given - -- expression. - checkExpr :: Map IR.QName Int -> IR.Expr -> [IR.Expr] -> Bool - checkExpr depthMap = checkExpr' + checkExpr :: DepthMap -> IR.Expr -> Bool + checkExpr depthMap = flip checkExpr' [] where - -- | Gets the depth of an expression within the structure of the decreasing - -- argument. - -- - -- Returns @Nothing@ if the given expression it is not a subterm of the - -- decreasing argument. The decreasing argument itself and its aliases - -- have a depth of @0@. - lookupDepth :: IR.Expr -> Maybe Int - lookupDepth (IR.Var _ varName _) = Map.lookup varName depthMap - lookupDepth _ = Nothing - -- | Tests whether the given expression is structurally smaller than the -- decreasing argument. isSmaller :: IR.Expr -> Bool - isSmaller = any (> 0) . lookupDepth + isSmaller = any (> 0) . flip lookupDepth depthMap + + -- | Like 'checkExpr' but the arguments the expression is applied to are + -- accumulated in the second argument. + checkExpr' :: IR.Expr -> [IR.Expr] -> Bool -- If one of the recursive functions is applied, there must be a -- structurally smaller variable in the decreasing position. - checkExpr' (IR.Var _ name _) args - = case Map.lookup name decArgMap of - Nothing -> True - Just decArgIndex | decArgIndex >= length args -> False - | otherwise -> isSmaller (args !! decArgIndex) - -- Function applications and @if@-expressions need to be checked - -- recursively. In case of applications we also remember the - -- arguments such that the case above can inspect the actual arguments. - checkExpr' (IR.App _ e1 e2 _) args = checkExpr' e1 (e2 : args) + checkExpr' (IR.Var _ name _) args = case Map.lookup name decArgMap of + Nothing -> True + Just decArgIndex | decArgIndex >= length args -> False + | otherwise -> isSmaller (args !! decArgIndex) + -- The arguments that an expression is applied to are accumulated in the + -- second argument. The argument still needs to be checked recursively + -- because it could contain recursive calls as well. + checkExpr' (IR.App _ e1 e2 _) args = checkExpr' e1 (e2 : args) && checkExpr' e2 [] - -- Recursively check branches of @if@ expressions. - checkExpr' (IR.If _ e1 e2 e3 _) _ - = checkExpr' e1 [] && checkExpr' e2 [] && checkExpr' e3 [] - -- Alternatives of @case@-expressions introduce variables at a depth one - -- level deeper than the scrutinee. - checkExpr' (IR.Case _ scrutinee alts _) _ = all - (checkAlt (lookupDepth scrutinee)) alts - -- The depth of arguments of lambda expressions is unknown. - checkExpr' (IR.Lambda _ args expr _) _ - = let depthMap' = withoutArgs args depthMap - in checkExpr depthMap' expr [] - -- The bindings of @let@-expressions introduce variables at the same depth - -- as the expressions on their right-hand sides. - checkExpr' (IR.Let _ binds expr _) _ - = let varPats = map IR.bindVarPat binds - varDepths = map (lookupDepth . IR.bindExpr) binds - depthMap' = withDepths (zip varPats varDepths) depthMap - in checkExpr depthMap' expr [] && all (checkBind depthMap') binds - -- Recursively check visibly applied expressions. + -- Visible type applications forward the arguments to the actually applied + -- function expression. checkExpr' (IR.TypeAppExpr _ expr _ _) args = checkExpr' expr args - -- Base expressions don't contain recursive calls. - checkExpr' (IR.Con _ _ _) _ = True - checkExpr' (IR.Undefined _ _) _ = True - checkExpr' (IR.ErrorExpr _ _ _) _ = True - checkExpr' (IR.IntLiteral _ _ _) _ = True + -- Check all other expressions recursively and extend the 'depthMap' if + -- there are variable binders. Arguments are not passed to subterms. + checkExpr' expr _ + = let children = childTerms expr + indicies = [1 .. length children] + depthMaps' = map (($ depthMap) . flip extendDepthMap expr) indicies + in all (uncurry checkExpr) (zip depthMaps' children) - -- | Applies 'checkExpr' on the right-hand side of an alternative of a - -- @case@ expression. - -- - -- The variable patterns shadow existing (structurally smaller or equal) - -- variables with the same name. The first argument is the depth of the - -- scrutinee (or @Nothing@ if it is not a subterm of the decreasing - -- argument). The variable patterns of the alternative are one level - -- deeper than the scrutinee. - checkAlt :: Maybe Int -> IR.Alt -> Bool - checkAlt srutineeDepth (IR.Alt _ _ varPats expr) - = let varDepths = repeat (succ <$> srutineeDepth) - depthMap' = withDepths (zip varPats varDepths) depthMap - in checkExpr depthMap' expr [] +------------------------------------------------------------------------------- +-- Depth Map -- +------------------------------------------------------------------------------- +-- | A map that maps the names of variables to their depth within the structure +-- of a potential decreasing argument. +-- +-- This map contains @0@ for variables that are structurally equal to the +-- decreasing argument. If it is not known how whether a variable is a +-- subterm of the decreasing argument, there is no entry. +type DepthMap = Map IR.QName Int - -- | Applies 'checkExpr' to the right-hand side of a binding of a - -- @let@ expression. - -- - -- The variables that are bound by the let expression should have been - -- shadowed already. - checkBind :: Map IR.QName Int -> IR.Bind -> Bool - checkBind depthMap' (IR.Bind _ _ expr) = checkExpr depthMap' expr [] +-- | Gets the depth of an expression within the structure of the decreasing +-- argument. +-- +-- Returns @Nothing@ if the given expression it is not a subterm of the +-- decreasing argument. The decreasing argument itself and its aliases +-- have a depth of @0@. +lookupDepth :: IR.Expr -> DepthMap -> Maybe Int +lookupDepth (IR.Var _ varName _) = Map.lookup varName +lookupDepth _ = const Nothing + +-- | Sets the depth of the variable that is bound by the given pattern +-- or removes the entry from the given 'DepthMap' if the new depth is +-- @Nothing@. +withDepth :: IR.VarPat -> Maybe Int -> DepthMap -> DepthMap +withDepth varPat maybeDepth = Map.alter (const maybeDepth) + (IR.varPatQName varPat) + +-- | Sets the depths of the variables that are bound by the given patterns +-- or removes the corresponding entries from the given 'DepthMap' if the new +-- depth is @Nothing@. +withDepths :: [(IR.VarPat, Maybe Int)] -> DepthMap -> DepthMap +withDepths = flip (foldr (uncurry withDepth)) - -- | Sets the depth of the variable that is bound by the given pattern - -- or removes the entry from the map if the new depth is @Nothing@. - withDepth :: IR.VarPat -> Maybe Int -> Map IR.QName Int -> Map IR.QName Int - withDepth varPat maybeDepth = Map.alter (const maybeDepth) - (IR.varPatQName varPat) +-- | Removes the given variables from the set of structurally smaller or equal +-- variables of the given 'DepthMap' (for example, because they are shadowed +-- by an argument from a lambda abstraction). +withoutArgs :: [IR.VarPat] -> DepthMap -> DepthMap +withoutArgs = flip Map.withoutKeys . Set.fromList . map IR.varPatQName + +-- | Builds a 'DepthMap' for variables that are bound at the given position +-- in the given expression. +depthMapAt + :: Pos -- ^ The position within the root expression to build the map for. + -> IR.Expr -- ^ The root expression. + -> IR.QName -- ^ The name of the decreasing argument. + -> DepthMap +depthMapAt p expr decArg = foldr (uncurry extendDepthMap) + (Map.singleton decArg 0) (mapMaybe selectParent (ancestorPos p)) + where + -- | Gets the subterm at the parent position of the given position as well + -- as the index (starting at @1@) of the position within its parent + -- position. + selectParent :: Pos -> Maybe (Int, IR.Expr) + selectParent = fmap (fmap (selectSubterm' expr)) . unConsPos - -- | Sets the depths of the variables that are bound by the given patterns - -- or removes the corresponding entries from the map if the new depth - -- is @Nothing@. - withDepths - :: [(IR.VarPat, Maybe Int)] -> Map IR.QName Int -> Map IR.QName Int - withDepths = flip (foldr (uncurry withDepth)) +-- | Updates the given 'DepthMap' for binders that bind variables in the child +-- expression with the given index (starting at @1@) in the given expression. +extendDepthMap :: Int -> IR.Expr -> DepthMap -> DepthMap - -- | Removes the given variables from the set of structurally smaller - -- variables (because they are shadowed by an argument from a lambda - -- abstraction or @case@-alternative). - withoutArgs :: [IR.VarPat] -> Map IR.QName Int -> Map IR.QName Int - withoutArgs = flip Map.withoutKeys . Set.fromList . map IR.varPatQName +-- The bindings of @let@-expressions introduce variables at the same depth +-- as the expressions on their right-hand sides. +extendDepthMap _ (IR.Let _ binds _ _) depthMap + = let bindDepths = map (flip lookupDepth depthMap . IR.bindExpr) binds + bindPats = map IR.bindVarPat binds + in withDepths (zip bindPats bindDepths) depthMap +-- Alternatives of @case@-expressions introduce variables at a depth one +-- level deeper than the scrutinee. +extendDepthMap childIndex (IR.Case _ scrutinee alts _) depthMap + | childIndex == 1 = depthMap + | otherwise = let srutineeDepth = lookupDepth scrutinee depthMap + varDepths = repeat (succ <$> srutineeDepth) + varPats = IR.altVarPats (alts !! (childIndex - 2)) + in withDepths (zip varPats varDepths) depthMap +-- The depth of arguments of lambda expressions is unknown. +extendDepthMap _ (IR.Lambda _ args _ _) depthMap = withoutArgs args depthMap +-- All other expressions don't introduce variables. +extendDepthMap _ (IR.Var _ _ _) depthMap = depthMap +extendDepthMap _ (IR.Con _ _ _) depthMap = depthMap +extendDepthMap _ (IR.App _ _ _ _) depthMap = depthMap +extendDepthMap _ (IR.TypeAppExpr _ _ _ _) depthMap = depthMap +extendDepthMap _ (IR.If _ _ _ _ _) depthMap = depthMap +extendDepthMap _ (IR.Undefined _ _) depthMap = depthMap +extendDepthMap _ (IR.ErrorExpr _ _ _) depthMap = depthMap +extendDepthMap _ (IR.IntLiteral _ _ _) depthMap = depthMap ------------------------------------------------------------------------------- -- Identifying Decreasing Arguments -- diff --git a/src/lib/FreeC/IR/Subterm.hs b/src/lib/FreeC/IR/Subterm.hs index 851b57b0..b4b5c8ac 100644 --- a/src/lib/FreeC/IR/Subterm.hs +++ b/src/lib/FreeC/IR/Subterm.hs @@ -11,7 +11,9 @@ module FreeC.IR.Subterm , Pos(..) , rootPos , consPos + , unConsPos , parentPos + , ancestorPos , allPos , above , below @@ -35,7 +37,7 @@ module FreeC.IR.Subterm import Control.Monad ( foldM ) import Data.Composition ( (.:) ) -import Data.List ( intersperse, isPrefixOf ) +import Data.List ( inits, intersperse, isPrefixOf ) import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map import Data.Maybe ( fromMaybe, listToMaybe ) @@ -178,12 +180,24 @@ rootPos = Pos [] consPos :: Int -> Pos -> Pos consPos p (Pos ps) = Pos (p : ps) +-- | Inverse function of 'consPos'. +-- +-- Returns @Nothing@ if the given position is the 'rootPos'. +unConsPos :: Pos -> Maybe (Int, Pos) +unConsPos (Pos []) = Nothing +unConsPos (Pos (p : ps)) = Just (p, Pos ps) + -- | Gets the parent position or @Nothing@ if the given position is the -- root position. parentPos :: Pos -> Maybe Pos parentPos (Pos ps) | null ps = Nothing | otherwise = Just (Pos (init ps)) +-- | Gets the positions of all ancestors of the the given position including +-- the position itself. +ancestorPos :: Pos -> [Pos] +ancestorPos (Pos ps) = map Pos (inits ps) + -- | Gets all valid positions of subterms within the given Haskell expression. allPos :: Subterm a => a -> [Pos] allPos term = rootPos From 6206d963dfc0abce39317511dbdd18eb6b9831b3 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Mon, 21 Sep 2020 23:44:32 +0200 Subject: [PATCH 091/120] Generate helper functions for `case` of aliases #209 The termination checker was previously extended to allow aliases of the decreasing argument or structurally smaller variables to be created using `let`-expressions without affecting termination. However, the Coq backend has not been extended accordingly. The missing helper functions are generated now but the arguments of the helper functions are not passed correctly. --- .../Coq/Converter/FuncDecl/Rec/WithHelpers.hs | 28 +++++++++---------- src/lib/FreeC/IR/Subterm.hs | 14 +++++++--- 2 files changed, 24 insertions(+), 18 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs index 0e937443..cea0ab18 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs @@ -14,6 +14,7 @@ import Data.List import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.Strict as Map import Data.Maybe ( fromJust ) +import Data.Set ( Set ) import qualified Data.Set as Set import FreeC.Backend.Coq.Analysis.DecreasingArguments @@ -102,23 +103,22 @@ transformRecFuncDecl decArg :: IR.QName decArg = argNames !! decArgIndex + -- | The names of variables that are structurally equal to the decreasing + -- argument at the given position. + decArgAliasesAt :: Pos -> Set IR.QName + decArgAliasesAt p = Map.keysSet (Map.filter (== 0) (depthMapAt p expr decArg)) + -- | The positions of @case@-expressions for the decreasing argument. caseExprsPos :: [Pos] - caseExprsPos = [p | p <- ps, not (any (below p) (delete p ps))] - where - ps :: [Pos] - ps = filter decArgNotShadowed (findSubtermPos isCaseExpr expr) + caseExprsPos = let ps = map snd (findSubtermWithPos isCaseExpr expr) + in [p | p <- ps, not (any (below p) (delete p ps))] -- | Tests whether the given expression is a @case@-expression for the - -- the decreasing argument. - isCaseExpr :: IR.Expr -> Bool - isCaseExpr (IR.Case _ (IR.Var _ varName _) _ _) = varName == decArg - isCaseExpr _ = False - - -- | Ensures that the decreasing argument is not shadowed by the binding - -- of a local variable at the given position. - decArgNotShadowed :: Pos -> Bool - decArgNotShadowed p = decArg `Set.notMember` boundVarsAt expr p + -- decreasing argument or a structurally equal variable. + isCaseExpr :: IR.Expr -> Pos -> Bool + isCaseExpr (IR.Case _ (IR.Var _ varName _) _ _) pos + = varName `Set.member` decArgAliasesAt pos + isCaseExpr _ _ = False -- | Generates the recursive helper function declaration for the @case@- -- expression at the given position of the right-hand side. @@ -162,7 +162,7 @@ transformRecFuncDecl -- Even though we know the type of the original and additional arguments -- the return type is unknown, since the right-hand side of @case@ -- expressions is not annotated. - -- The helper function uses all effects that are used by the original + -- The helper function uses all effects that are used by the original -- function. freeArgsNeeded <- inEnv $ needsFreeArgs name effects <- inEnv $ lookupEffects name diff --git a/src/lib/FreeC/IR/Subterm.hs b/src/lib/FreeC/IR/Subterm.hs index b4b5c8ac..b409a9d7 100644 --- a/src/lib/FreeC/IR/Subterm.hs +++ b/src/lib/FreeC/IR/Subterm.hs @@ -28,6 +28,7 @@ module FreeC.IR.Subterm , replaceSubterms' -- * Searching for Subterms , findSubtermPos + , findSubtermWithPos , findSubterms , findFirstSubterm -- * Bound Variables @@ -290,14 +291,19 @@ replaceSubterms' = foldl (\term (pos, term') -> replaceSubterm' term pos term') -- | Gets a list of positions for subterms of the given expression that -- satisfy the provided predicate. findSubtermPos :: Subterm a => (a -> Bool) -> a -> [Pos] -findSubtermPos predicate term = filter (predicate . selectSubterm' term) - (allPos term) +findSubtermPos predicate = map snd + . findSubtermWithPos (flip (const predicate)) + +-- | Like 'findSubtermPos' but the predicate gets the position as an additional +-- argument and also returns the subterm. +findSubtermWithPos :: Subterm a => (a -> Pos -> Bool) -> a -> [(a, Pos)] +findSubtermWithPos predicate term = filter (uncurry predicate) + (map (selectSubterm' term &&& id) (allPos term)) -- | Gets a list of subterms of the given expression that satisfy the -- provided predicate. findSubterms :: Subterm a => (a -> Bool) -> a -> [a] -findSubterms predicate term = filter predicate - (map (selectSubterm' term) (allPos term)) +findSubterms predicate = map fst . findSubtermWithPos (flip (const predicate)) -- | Gets the first subterm of the given expression that satisfies the -- provided predicate. From 39581469e6766c55d64802a027fb65c37aac0ac9 Mon Sep 17 00:00:00 2001 From: Daniel Teut Date: Mon, 21 Sep 2020 23:53:31 +0200 Subject: [PATCH 092/120] Add shadowing to let in variable counting #196 --- src/lib/FreeC/LiftedIR/Converter/Expr.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/lib/FreeC/LiftedIR/Converter/Expr.hs b/src/lib/FreeC/LiftedIR/Converter/Expr.hs index cf11803a..9a5a9ab2 100644 --- a/src/lib/FreeC/LiftedIR/Converter/Expr.hs +++ b/src/lib/FreeC/LiftedIR/Converter/Expr.hs @@ -342,7 +342,7 @@ liftBinds ((IR.Bind srcSpan varPat bindExpr) : bs) expr = localEnv $ do bindExpr' <- liftExpr bindExpr let varName = IR.varPatQName varPat countExprs = expr : map IR.bindExpr bs - count = sum (map (countVarInExpr varName) countExprs) + count = sum $ map (countVarInExpr varName) countExprs shareOp | count > 1 = LIR.Share | otherwise = LIR.Call shareExpr = shareOp srcSpan bindExpr' shareType' @@ -369,8 +369,10 @@ countVarInExpr varName = countVarInExpr' countVarInExpr' IR.ErrorExpr {} = 0 countVarInExpr' IR.IntLiteral {} = 0 countVarInExpr' (IR.Lambda _ varPats expr _) = countVarInBinds varPats expr - countVarInExpr' (IR.Let _ binds expr _) = countVarInExpr' expr - + sum (map (countVarInExpr' . IR.bindExpr) binds) + countVarInExpr' (IR.Let _ binds expr _) + = let varPats = map IR.bindVarPat binds + in sum (map (countVarInBinds varPats . IR.bindExpr) binds) + + countVarInBinds varPats expr -- | Returns the number of all occurrences of the variable with the given name -- in the given expression. From 241d9666deb80299317cf07076b3de64c43f808f Mon Sep 17 00:00:00 2001 From: Daniel Teut Date: Tue, 22 Sep 2020 00:08:44 +0200 Subject: [PATCH 093/120] Add test case for let shadowing #196 --- src/test/FreeC/Backend/Coq/Converter/ExprTests.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/test/FreeC/Backend/Coq/Converter/ExprTests.hs b/src/test/FreeC/Backend/Coq/Converter/ExprTests.hs index d293b228..9b07f50a 100644 --- a/src/test/FreeC/Backend/Coq/Converter/ExprTests.hs +++ b/src/test/FreeC/Backend/Coq/Converter/ExprTests.hs @@ -325,6 +325,15 @@ testConvertLet = context "let expressions" $ do shouldConvertExprTo "let {(x' :: a) = x} in \\(x' :: a) -> f @a x' x'" $ "@call Shape Pos S a x >>= (fun (x' : Free Shape Pos a) =>" ++ " pure (fun (x'0 : Free Shape Pos a) => @f Shape Pos a x'0 x'0))" + it "ignores shadowed variables in let expressions" $ shouldSucceedWith $ do + "f" <- defineTestFunc "f" 2 "forall a. a -> a -> a" + "x" <- defineTestVar "x" + "a" <- defineTestTypeVar "a" + shouldConvertExprTo + "let {(x' :: a) = x} in let {(x' :: a) = x} in f @a x' x'" + $ "@call Shape Pos S a x >>=" + ++ " (fun (x' : Free Shape Pos a) => @share Shape Pos S a _ x >>=" + ++ " (fun (x'0 : Free Shape Pos a) => @f Shape Pos a x'0 x'0))" ------------------------------------------------------------------------------- -- Lambda Abstractions -- From b85dca3cea3dd8f809f485046573ade0ff7c25ad Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Fri, 25 Sep 2020 11:52:40 +0200 Subject: [PATCH 094/120] Add prefixes for normalized and shared variables to Fresh #150 --- src/lib/FreeC/Environment/Fresh.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/lib/FreeC/Environment/Fresh.hs b/src/lib/FreeC/Environment/Fresh.hs index 600888ad..893bfd8f 100644 --- a/src/lib/FreeC/Environment/Fresh.hs +++ b/src/lib/FreeC/Environment/Fresh.hs @@ -6,6 +6,8 @@ module FreeC.Environment.Fresh ( -- * Prefixes freshArgPrefix + , freshNormalformArgPrefix + , freshSharingArgPrefix , freshFuncPrefix , freshBoolPrefix , freshTypeVarPrefix @@ -44,6 +46,14 @@ import FreeC.Monad.Converter freshArgPrefix :: String freshArgPrefix = "x" +-- | The prefix to use for variables artificially introduced by normalization. +freshNormalformArgPrefix :: String +freshSharingArgPrefix = "nx" + +-- | The prefix to use for variables artificially introduced by sharing. +freshSharingArgPrefix :: String +freshNormalformArgPrefix = "sx" + -- | The prefix to use for artificially introduced variables of type @a -> b@. freshFuncPrefix :: String freshFuncPrefix = "f" From a6c5ea094aa923804b1a06e091261e360310fe82 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Fri, 25 Sep 2020 11:53:02 +0200 Subject: [PATCH 095/120] Use new data type for stripped type #150 --- .../Converter/TypeDecl/TypeclassInstances.hs | 175 +++++++++--------- 1 file changed, 90 insertions(+), 85 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs index 9b716890..72132936 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs @@ -103,6 +103,7 @@ module FreeC.Backend.Coq.Converter.TypeDecl.TypeclassInstances where import Control.Monad ( foldM, mapAndUnzipM, replicateM ) +import Control.Monad.Extra ( concatMapM ) import Data.List ( nub ) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.Strict as Map @@ -114,7 +115,7 @@ import qualified FreeC.Backend.Coq.Syntax as Coq import FreeC.Environment import FreeC.Environment.Entry import FreeC.Environment.Fresh - ( freshArgPrefix, freshCoqQualid, freshHaskellIdent ) + ( freshArgPrefix, freshNormalformArgPrefix, freshSharingArgPrefix, freshTypeVarPrefix, freshCoqQualid, freshHaskellIdent ) import FreeC.Environment.LookupOrFail import FreeC.IR.SrcSpan ( SrcSpan(NoSrcSpan) ) import FreeC.IR.Subst @@ -127,8 +128,17 @@ import FreeC.Pretty ------------------------------------------------------------------------------- -- Instance Generation -- ------------------------------------------------------------------------------- +-- | Data type for a type with certain components replaced by underscores. +data StrippedType = StrippedType | StrippedTypeCon IR.TypeConName [StrippedType] + deriving (Eq, Ord, Show) + +isStripped :: StrippedType -> Bool +isStripped StrippedType = True +isStripped _ = False + -- | Type synonym for a map mapping types to function names. -type TypeMap = Map.Map IR.Type Coq.Qualid +type TypeMap' = Map.Map IR.Type Coq.Qualid +type TypeMap = Map.Map StrippedType Coq.Qualid -- | Builds instances for all supported typeclasses. -- Currently, @Normalform@ and @ShareableArgs@ instances are generated. @@ -149,7 +159,7 @@ generateTypeclassInstances dataDecls = do -- This leaves exactly the types with indirect recursion, with all non-recursive -- components replaced by underscores. let recTypeList = map - (filter (\t -> not (t `elem` declTypes || IR.isTypeVar t))) reducedTypes + (filter (\t -> not (t `elem` declTypes || isStripped t))) reducedTypes -- Construct @Normalform@ instances. nfInstances <- buildInstances recTypeList (fromJust $ Coq.unpackQualid Coq.Base.nf') @@ -165,9 +175,9 @@ generateTypeclassInstances dataDecls = do -- | The (mutually recursive) data types for which we are defining -- instances, converted to types. All type variable are converted -- to underscores. - declTypes :: [IR.Type] - declTypes = [IR.typeConApp NoSrcSpan (IR.typeDeclQName dataDecl) - (replicate (length (IR.typeDeclArgs dataDecl)) placeholderVar) + declTypes :: [StrippedType] + declTypes = [StrippedTypeCon (IR.typeDeclQName dataDecl) + (replicate (length (IR.typeDeclArgs dataDecl)) StrippedType) | dataDecl <- dataDecls ] @@ -179,16 +189,16 @@ generateTypeclassInstances dataDecls = do -- | Constructs instances of a typeclass for a set of mutually recursive -- types. The typeclass is specified by the arguments. buildInstances - :: [[IR.Type]] + :: [[StrippedType]] -- ^ For each data declaration, this list contains the occurrences of -- indirect recursion in the constructors of that data declaration. -> String -- ^ The name of the class function. -> String -- ^ The name of the typeclass. - -> (IR.Type + -> (StrippedType -> Coq.Qualid -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term)) -- ^ A function to get class-specific binders and return types. - -> (TypeMap -> Coq.Qualid -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term) + -> (TypeMap -> Coq.Qualid -> [(StrippedType, Coq.Qualid)] -> Converter Coq.Term) -- ^ A function to compute a class-specific value given a data constructor -- with arguments. -> Converter [Coq.Sentence] @@ -216,8 +226,8 @@ generateTypeclassInstances dataDecls = do :: TypeMap -- ^ A map to map occurrences of the top-level types to recursive -- function calls. - -> IR.Type -- ^ The type for which we are defining an instance. - -> [IR.Type] -- ^ The list of indirectly recursive types. + -> StrippedType -- ^ The type for which we are defining an instance. + -> [StrippedType] -- ^ The list of indirectly recursive types. -> Converter (Coq.FixBody, Coq.Sentence) buildFixBodyAndInstance topLevelMap t recTypes = do -- Locally visible definitions are defined in a local environment. @@ -246,7 +256,7 @@ generateTypeclassInstances dataDecls = do buildInstance :: TypeMap -- ^ A mapping from (in)directly recursive types to function names. - -> IR.Type -- ^ The type for which we are defining an instance. + -> StrippedType -- ^ The type for which we are defining an instance. -> [Coq.Binder] -- ^ The binders for the type class instance. -> Coq.Term -- ^ The type of the instance. -> Converter Coq.Sentence @@ -267,10 +277,10 @@ generateTypeclassInstances dataDecls = do :: TypeMap -- ^ A mapping from (in)directly recursive types to function names. -> Coq.Qualid -- ^ The name of the argument of type @t@. - -> IR.Type -- ^ The type for which we are defining an instance. + -> StrippedType -- ^ The type for which we are defining an instance. -> [Coq.Binder] -- ^ The binders for the class function. -> Coq.Term -- ^ The return type of the class function. - -> [IR.Type] -- ^ The list of indirectly recursive types. + -> [StrippedType] -- ^ The list of indirectly recursive types. -> Converter Coq.FixBody makeFixBody m varName t binders retType recTypes = do rhs <- generateBody m varName t recTypes @@ -285,8 +295,8 @@ generateTypeclassInstances dataDecls = do :: TypeMap -- ^ A mapping from (in)directly recursive types to function names. -> Coq.Qualid -- ^ The name of the argument of type @t@. - -> IR.Type -- ^ The type for which we are defining an instance. - -> [IR.Type] -- ^ The list of indirectly recursive types. + -> StrippedType -- ^ The type for which we are defining an instance. + -> [StrippedType] -- ^ The list of indirectly recursive types. -> Converter Coq.Term -- If there are no indirectly recursive types, match on the constructors of @@ -313,23 +323,23 @@ generateTypeclassInstances dataDecls = do Nothing (Just retType) letBody))) inBody -- | Matches on the constructors of a type. - matchConstructors :: TypeMap -> Coq.Qualid -> IR.Type -> Converter Coq.Term - matchConstructors m varName t = do - let Just conName = IR.getTypeConName t + matchConstructors :: TypeMap -> Coq.Qualid -> StrippedType -> Converter Coq.Term + matchConstructors m varName t@(StrippedTypeCon conName _) = do entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName equations <- mapM (buildEquation m t) (entryConsNames entry) return $ Coq.match (Coq.Qualid varName) equations + matchConstructors _ _ StrippedType = error "generateTypeclassInstances: unexpected type placeholder." -- | Creates a match equation on a given data constructor with a -- class-specific right-hand side. - buildEquation :: TypeMap -> IR.Type -> IR.ConName -> Converter Coq.Equation + buildEquation :: TypeMap -> StrippedType -> IR.ConName -> Converter Coq.Equation buildEquation m t conName = do conEntry <- lookupEntryOrFail NoSrcSpan IR.ValueScope conName retType <- expandAllTypeSynonyms (entryReturnType conEntry) -- Get the Coq name of the constructor. let conIdent = entryIdent conEntry -- Generate fresh variables for the constructor's parameters. - conArgIdents <- freshQualids (entryArity conEntry) ("f" ++ freshArgPrefix) + conArgIdents <- freshQualids (entryArity conEntry) freshArgPrefix -- Replace all underscores with fresh variables before unification. tFreshVars <- insertFreshVariables t subst <- unifyOrFail NoSrcSpan tFreshVars retType @@ -351,7 +361,7 @@ generateTypeclassInstances dataDecls = do ------------------------------------------------------------------------------- -- | The binders and return types for the @Normalform@ class function and instance. nfBindersAndReturnType - :: IR.Type + :: StrippedType -- ^ The type @t@ for which we are defining an instance. -> Coq.Qualid -- ^ The name of the argument of type @t@. -> Converter @@ -367,8 +377,8 @@ generateTypeclassInstances dataDecls = do -- The type is transformed to a Coq type twice, once with @Shape@ and -- @Pos@ as arguments for the original type, once with @Identity.Shape@ -- and @Identity.Pos@ as arguments for the normalized result type. - (sourceType, sourceVars) <- toCoqType "a" shapeAndPos t - (targetType, targetVars) <- toCoqType "b" idShapeAndPos t + (sourceType, sourceVars) <- toCoqType freshTypeVarPrefix shapeAndPos t + (targetType, targetVars) <- toCoqType freshTypeVarPrefix idShapeAndPos t -- For each type variable @ai@, build a constraint -- @`{Normalform Shape Pos ai bi}@. let constraints = zipWith Coq.Base.normalformBinder sourceVars targetVars @@ -389,7 +399,7 @@ generateTypeclassInstances dataDecls = do :: TypeMap -- ^ A map to associate types with the appropriate functions to call. -> Coq.Qualid -- ^ The data constructor used to build a value. - -> [(IR.Type, Coq.Qualid)] + -> [(StrippedType, Coq.Qualid)] -- ^ The types and names of the constructor's arguments. -> Converter Coq.Term buildNormalformValue nameMap consName = buildNormalformValue' [] @@ -397,7 +407,7 @@ generateTypeclassInstances dataDecls = do -- | Like 'buildNormalformValue', but with an additional parameter to accumulate -- bound variables. buildNormalformValue' - :: [Coq.Qualid] -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term + :: [Coq.Qualid] -> [(StrippedType, Coq.Qualid)] -> Converter Coq.Term -- If all components have been normalized, apply the constructor to -- the normalized components. @@ -415,7 +425,7 @@ generateTypeclassInstances dataDecls = do -- must be bound (to a fresh variable). x <- freshCoqQualid freshArgPrefix -- The result of the normalization will also be bound to a fresh variable. - nx <- freshCoqQualid ("n" ++ freshArgPrefix) + nx <- freshCoqQualid freshNormalformArgPrefix -- Do the rest of the computation with the added bound result. rhs <- buildNormalformValue' (nx : boundVars) consVars -- Construct the actual bindings and return the result. @@ -438,7 +448,7 @@ generateTypeclassInstances dataDecls = do ------------------------------------------------------------------------------- -- | The binders and return types for the @ShareableArgs@ class function and instance. shareArgsBindersAndReturnType - :: IR.Type + :: StrippedType -- ^ The type @t@ for which we are defining an instance. -> Coq.Qualid -- ^ The name of the argument of type @t@. -> Converter @@ -466,17 +476,17 @@ generateTypeclassInstances dataDecls = do :: TypeMap -- ^ A map to associate types with the appropriate functions to call. -> Coq.Qualid -- ^ The data constructor used to build a value. - -> [(IR.Type, Coq.Qualid)] + -> [(StrippedType, Coq.Qualid)] -- ^ The types and names of the constructor's arguments. -> Converter Coq.Term buildShareArgsValue nameMap consName = buildShareArgsValue' [] where buildShareArgsValue' - :: [Coq.Qualid] -> [(IR.Type, Coq.Qualid)] -> Converter Coq.Term + :: [Coq.Qualid] -> [(StrippedType, Coq.Qualid)] -> Converter Coq.Term buildShareArgsValue' vals [] = generatePure (Coq.app (Coq.Qualid consName) (map Coq.Qualid (reverse vals))) buildShareArgsValue' vals ((t, varName) : consVars) = do - sx <- freshCoqQualid ("s" ++ freshArgPrefix) + sx <- freshCoqQualid freshSharingArgPrefix rhs <- buildShareArgsValue' (sx : vals) consVars case Map.lookup t nameMap of Just funcName -> do @@ -498,27 +508,22 @@ generateTypeclassInstances dataDecls = do ------------------------------------------------------------------------------- -- | Creates an entry with a unique name for each of the given types and -- inserts them into the given map. - nameFunctionsAndInsert :: String -> TypeMap -> [IR.Type] -> Converter TypeMap + nameFunctionsAndInsert :: String -> TypeMap -> [StrippedType] -> Converter TypeMap nameFunctionsAndInsert prefix = foldM (nameFunctionAndInsert prefix) -- | Like 'nameFunctionsAndInsert', but for a single type. - nameFunctionAndInsert :: String -> TypeMap -> IR.Type -> Converter TypeMap + nameFunctionAndInsert :: String -> TypeMap -> StrippedType -> Converter TypeMap nameFunctionAndInsert prefix m t = do name <- nameFunction prefix t return (Map.insert t name m) -- | Names a function based on a type expression while avoiding name clashes -- with other identifiers. - nameFunction :: String -> IR.Type -> Converter Coq.Qualid + nameFunction :: String -> StrippedType -> Converter Coq.Qualid nameFunction prefix t = do prettyType <- showPrettyType t freshCoqQualid (prefix ++ prettyType) - -- | A type variable that represents irrelevant parts of a type expression. - -- Represented by an underscore. - placeholderVar :: IR.Type - placeholderVar = IR.TypeVar NoSrcSpan "_" - -- | Collects all fully-applied type constructors of arity at least 1 -- (including their arguments) that occur in the given type. All arguments -- that do not contain occurrences of the types for which we are defining @@ -527,14 +532,14 @@ generateTypeclassInstances dataDecls = do -- types for which we must define a separate function in the instance -- definition, where all occurrences of @_@ represent the polymorphic -- components of the function. - collectSubTypes :: IR.Type -> [IR.Type] + collectSubTypes :: IR.Type -> [StrippedType] collectSubTypes = collectFullyAppliedTypes True where -- | Like 'collectSubTypes', but with an additional flag to denote whether -- @t@ is a full application of a type constructor, e.g. @Pair Int Bool@, -- or a partial application, e.g. @Pair Int@. -- Only full applications are collected. - collectFullyAppliedTypes :: Bool -> IR.Type -> [IR.Type] + collectFullyAppliedTypes :: Bool -> IR.Type -> [StrippedType] collectFullyAppliedTypes fullApplication t@(IR.TypeApp _ l r) -- The left-hand side of a type application is the partial -- application of a type constructor. @@ -552,61 +557,54 @@ generateTypeclassInstances dataDecls = do -- | Returns the same type with all type expressions that do not contain one -- of the type constructors for which we are defining instances replaced -- with the type variable @_@. - stripType :: IR.Type -> IR.Type - stripType t = stripType' t False + stripType :: IR.Type -> StrippedType + stripType = stripType' False where -- | Like 'stripType', but with an additional flag to denote whether an -- occurrence of a relevant type was found in an argument of a type -- application. -- This is necessary so that, for example, @Pair Bool t@ is not -- transformed to @_ t@, but to @Pair _ t@. - stripType' :: IR.Type -> Bool -> IR.Type - stripType' (IR.TypeCon _ conName) flag - | flag || conName `elem` typeConNames = IR.TypeCon NoSrcSpan conName - | otherwise = placeholderVar + stripType' :: Bool -> IR.Type -> StrippedType + stripType' flag (IR.TypeCon _ conName) + | flag || conName `elem` typeConNames = StrippedTypeCon conName [] + | otherwise = StrippedType -- For a type application, check if a relevant type occurs in its -- right-hand side. - stripType' (IR.TypeApp _ l r) flag = case stripType' r False of + stripType' flag (IR.TypeApp _ l r) = case stripType' False r of -- If not, check if a relevant type occurs in its left-hand side, -- otherwise replace the whole expression with an underscore. - r'@(IR.TypeVar _ _) -> case stripType' l flag of - IR.TypeVar _ _ -> placeholderVar - l' -> IR.TypeApp NoSrcSpan l' r' + StrippedType -> case stripType' flag l of + StrippedType -> StrippedType + StrippedTypeCon con args -> StrippedTypeCon con (args ++ [StrippedType]) -- If a relevant type does occur in the right-hand side, -- the type application must be preserved, so only its arguments are -- stripped. - r' -> IR.TypeApp NoSrcSpan (stripType' l True) r' + r' -> let StrippedTypeCon con args = stripType' True l in StrippedTypeCon con (args ++ [r']) -- Type variables and function types are not relevant and are replaced by @_@. - stripType' _ _ = placeholderVar - - -- | Like @showPretty@, but uses the Coq identifiers of the type and its components. - showPrettyType :: IR.Type -> Converter String - - -- For a type variable, show its name. - showPrettyType (IR.TypeVar _ varName) = return (showPretty varName) - -- For a type constructor, return its Coq identifier as a string. - showPrettyType (IR.TypeCon _ conName) = fromJust . (>>= Coq.unpackQualid) - <$> inEnv (lookupIdent IR.TypeScope conName) - -- For a type application, convert both sides and concatenate them. - showPrettyType (IR.TypeApp _ l r) = do - lPretty <- showPrettyType l - rPretty <- showPrettyType r - return (lPretty ++ rPretty) - -- Function types should have been converted into variables. - showPrettyType (IR.FuncType _ _ _) - = error "Function types should have been eliminated." - - -- | Replaces all variables in a type with fresh variables. - insertFreshVariables :: IR.Type -> Converter IR.Type - insertFreshVariables (IR.TypeVar srcSpan _) = do - freshVar <- freshHaskellIdent freshArgPrefix - return (IR.TypeVar srcSpan freshVar) - insertFreshVariables (IR.TypeApp srcSpan l r) = do - lFresh <- insertFreshVariables l - rFresh <- insertFreshVariables r - return (IR.TypeApp srcSpan lFresh rFresh) - -- Type constructors and function types are returned as-is. - insertFreshVariables t = return t + stripType' _ _ = StrippedType + + showPrettyType :: StrippedType -> Converter String + -- For a placeholder, show "_". + showPrettyType StrippedType = return "_" + -- For a type constructor and its arguments, return the constructor's + -- Coq identifier as a string with the conversions of the arguments appended. + showPrettyType (StrippedTypeCon con args) = do + prettyCon <- fromJust . (>>= Coq.unpackQualid) + <$> inEnv (lookupIdent IR.TypeScope con) + prettyArgs <- concatMapM showPrettyType args + return (prettyCon ++ prettyArgs) + + + -- | Converts a @StrippedType@ to an @IR.Type@, replacing all + -- placeholders with fresh variables. + insertFreshVariables :: StrippedType -> Converter IR.Type + insertFreshVariables StrippedType = do + freshVar <- freshHaskellIdent freshArgPrefix + return (IR.TypeVar NoSrcSpan freshVar) + insertFreshVariables (StrippedTypeCon con args) = do + args' <- mapM insertFreshVariables args + return (foldl (IR.TypeApp NoSrcSpan) (IR.TypeCon NoSrcSpan con) args') -- | Binders for (implicit) Shape and Pos arguments. -- @@ -648,13 +646,20 @@ generateTypeclassInstances dataDecls = do toCoqType :: String -- ^ The prefix of the fresh variables. -> [Coq.Term] -- ^ A list of additional arguments, e.g. Shape and Pos. - -> IR.Type -- ^ The type to convert. + -> StrippedType -- ^ The type to convert. -> Converter (Coq.Term, [Coq.Qualid]) -- A type variable is translated into a fresh type variable. - toCoqType varPrefix _ (IR.TypeVar _ _) = do + toCoqType varPrefix _ StrippedType = do x <- freshCoqQualid varPrefix return (Coq.Qualid x, [x]) + toCoqType varPrefix extraArgs (StrippedTypeCon con args) = do + entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope con + (coqArgs,freshVars) <- mapAndUnzipM (toCoqType varPrefix extraArgs) args + return (Coq.app (Coq.Qualid (entryIdent entry)) (extraArgs ++ coqArgs), concat freshVars ) + + + {- -- A type constructor is applied to the given arguments. toCoqType _ extraArgs (IR.TypeCon _ conName) = do entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName @@ -668,7 +673,7 @@ generateTypeclassInstances dataDecls = do -- Function types were removed by 'stripType'. toCoqType _ _ (IR.FuncType _ _ _) = error "Function types should have been eliminated." - + -} -- | Produces @n@ new Coq identifiers (Qualids) with the same prefix. freshQualids :: Int -> String -> Converter [Coq.Qualid] freshQualids n prefix = replicateM n (freshCoqQualid prefix) From 341a40113198fa433725dc9157fc53cfdc102117 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Fri, 25 Sep 2020 12:09:04 +0200 Subject: [PATCH 096/120] Remove Ord instance from SrcSpan and Type #150 --- src/lib/FreeC/IR/SrcSpan.hs | 2 +- src/lib/FreeC/IR/Syntax/Type.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/lib/FreeC/IR/SrcSpan.hs b/src/lib/FreeC/IR/SrcSpan.hs index 15fb198e..85c1c0df 100644 --- a/src/lib/FreeC/IR/SrcSpan.hs +++ b/src/lib/FreeC/IR/SrcSpan.hs @@ -79,7 +79,7 @@ data SrcSpan | FileSpan -- ^ Points to an unknown location in the given file. { srcSpanFilename :: String -- ^ The name of the file. } - deriving ( Eq, Ord, Show ) + deriving ( Eq, Show ) ------------------------------------------------------------------------------- -- Predicates -- diff --git a/src/lib/FreeC/IR/Syntax/Type.hs b/src/lib/FreeC/IR/Syntax/Type.hs index 96391537..9cba7ebe 100644 --- a/src/lib/FreeC/IR/Syntax/Type.hs +++ b/src/lib/FreeC/IR/Syntax/Type.hs @@ -30,7 +30,7 @@ data Type , funcTypeArg :: Type , funcTypeRes :: Type } - deriving ( Eq, Ord, Show ) + deriving ( Eq, Show ) -- | Creates a type constructor application type. -- From 982ae7c978f491630dd3fcbed95aab3713f9b7d0 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Sat, 26 Sep 2020 21:25:34 +0200 Subject: [PATCH 097/120] Format code #158 --- src/lib/FreeC/Backend/Coq/Converter/Module.hs | 2 +- src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/Module.hs b/src/lib/FreeC/Backend/Coq/Converter/Module.hs index a34ea9ff..900057ad 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/Module.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/Module.hs @@ -45,7 +45,7 @@ convertTypeDecls typeDecls = do let components = typeDependencyComponents typeDecls (sentences, qualSmartCons) <- concatUnzip <$> mapM convertTypeComponent components - let + let -- Put qualified notations into a single local module qualNotModule = if null qualSmartCons then [] diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index ff59c0db..842f27c0 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -350,7 +350,7 @@ convertDataDecl (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do fArgTypes <- mapM convertType argTypes (argIdents, argBinders) <- mapAndUnzipM convertAnonymousArg (map Just argTypes) - let + let -- We need an induction hypothesis for every argument that has the same -- type as the constructor but lifted into the free monad. addHypotheses' :: [(Coq.Term, Coq.Qualid)] -> Coq.Term -> Coq.Term From c8137c87a0bcd5db69cacfbcec512b2cbcc75887 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 28 Sep 2020 10:56:27 +0200 Subject: [PATCH 098/120] Incorporate changes from issue-202 pertaining to Normalform generation #150 --- base/coq/Free/Class/Normalform.v | 25 +-- base/coq/Prelude/Bool.v | 2 +- base/coq/Prelude/Integer.v | 2 +- base/coq/Prelude/List.v | 13 +- base/coq/Prelude/Pair.v | 16 +- base/coq/Prelude/Unit.v | 2 +- src/lib/FreeC/Backend/Coq/Base.hs | 21 ++- .../Converter/TypeDecl/TypeclassInstances.hs | 161 +++++++++--------- src/lib/FreeC/Environment/Fresh.hs | 4 +- .../Backend/Coq/Converter/TypeDeclTests.hs | 49 +++--- 10 files changed, 153 insertions(+), 142 deletions(-) diff --git a/base/coq/Free/Class/Normalform.v b/base/coq/Free/Class/Normalform.v index d6e0cb83..f645fcc7 100644 --- a/base/coq/Free/Class/Normalform.v +++ b/base/coq/Free/Class/Normalform.v @@ -5,32 +5,37 @@ From Base Require Import Free.Monad. +From Base Require Import Free.Instance.Identity. + Class Normalform (Shape : Type) (Pos : Shape -> Type) - (A B : Type) := + (A : Type) := { + (** The normalized return type. *) + nType : Type; (** The function is split into two parts due to termination check errors for recursive data types. *) - nf' : A -> Free Shape Pos B + nf' : A -> Free Shape Pos nType }. -Definition nf {Shape : Type} {Pos : Shape -> Type} {A B : Type} - `{Normalform Shape Pos A B} (n : Free Shape Pos A) - : Free Shape Pos B +(* Normalizes a Free value. *) +Definition nf {Shape : Type} {Pos : Shape -> Type} {A : Type} + `{Normalform Shape Pos A} (n : Free Shape Pos A) + : Free Shape Pos nType := n >>= nf'. -Lemma nfImpure {Shape : Type} {Pos : Shape -> Type} {A B : Type} - `{Normalform Shape Pos A B} +Lemma nfImpure {Shape : Type} {Pos : Shape -> Type} {A : Type} + `{Normalform Shape Pos A} : forall s (pf : _ -> Free Shape Pos A), nf (impure s pf) = impure s (fun p => nf (pf p)). Proof. trivial. Qed. -Lemma nfPure {Shape : Type} {Pos : Shape -> Type} {A B : Type} - `{Normalform Shape Pos A B} : forall (x : A), +Lemma nfPure {Shape : Type} {Pos : Shape -> Type} {A : Type} + `{Normalform Shape Pos A} : forall (x : A), nf (pure x) = nf' x. Proof. trivial. Qed. (* Normalform instance for functions. Effects inside of functions are not pulled to the root. *) Instance NormalformFunc (Shape : Type) (Pos : Shape -> Type) (A B : Type) - : Normalform Shape Pos (A -> B) (A -> B) := + : Normalform Shape Pos (A -> B) := { nf' := pure }. diff --git a/base/coq/Prelude/Bool.v b/base/coq/Prelude/Bool.v index 8a1d46c7..df91ac78 100644 --- a/base/coq/Prelude/Bool.v +++ b/base/coq/Prelude/Bool.v @@ -40,7 +40,7 @@ End SecBool. (* Normalform instance for Bool *) Instance NormalformBool (Shape : Type) (Pos : Shape -> Type) - : Normalform Shape Pos (Bool Shape Pos) (Bool Identity.Shape Identity.Pos) + : Normalform Shape Pos (Bool Shape Pos) := { nf' := pure }. (* ShareableArgs instance for Bool *) diff --git a/base/coq/Prelude/Integer.v b/base/coq/Prelude/Integer.v index dd4c7409..f6201b91 100644 --- a/base/coq/Prelude/Integer.v +++ b/base/coq/Prelude/Integer.v @@ -99,7 +99,7 @@ End SecInteger. (* Normalform instance for Integer *) Instance NormalformInteger (Shape : Type) (Pos : Shape -> Type) - : Normalform Shape Pos (Integer Shape Pos) (Integer Identity.Shape Identity.Pos) + : Normalform Shape Pos (Integer Shape Pos) := { nf' := pure }. (* ShareableArgs instance for Integer *) diff --git a/base/coq/Prelude/List.v b/base/coq/Prelude/List.v index bdab5f69..c4bdb112 100644 --- a/base/coq/Prelude/List.v +++ b/base/coq/Prelude/List.v @@ -43,24 +43,25 @@ Section SecListNF. Variable Shape : Type. Variable Pos : Shape -> Type. - Variable A B : Type. + Variable A : Type. - Fixpoint nf'List `{Normalform Shape Pos A B} + Fixpoint nf'List `{Normalform Shape Pos A} (l : List Shape Pos A) - : Free Shape Pos (List Identity.Shape Identity.Pos B) + : Free Shape Pos (List Identity.Shape Identity.Pos nType) := match l with | nil => pure nil | cons fx fxs => nf fx >>= fun nx => fxs >>= fun xs => nf'List xs >>= fun nxs => - pure (cons (pure nx) (pure nxs)) + pure (cons (pure nx) + (pure nxs)) end. - Global Instance NormalformList `{Normalform Shape Pos A B} + Global Instance NormalformList `{Normalform Shape Pos A} : Normalform Shape Pos (List Shape Pos A) - (List Identity.Shape Identity.Pos B) := { nf' := nf'List }. + End SecListNF. diff --git a/base/coq/Prelude/Pair.v b/base/coq/Prelude/Pair.v index 5a0728f2..1066504a 100644 --- a/base/coq/Prelude/Pair.v +++ b/base/coq/Prelude/Pair.v @@ -2,6 +2,8 @@ From Base Require Import Free. From Base Require Import Free.Instance.Identity. From Base Require Import Free.Malias. +From Base Require Import Prelude.Bool. + Section SecPair. Variable Shape : Type. Variable Pos : Shape -> Type. @@ -30,22 +32,22 @@ Section SecNFPair. Variable Shape : Type. Variable Pos : Shape -> Type. - Variable A B C D : Type. + Variable A B : Type. - Definition nf'Pair `{Normalform Shape Pos A C} - `{Normalform Shape Pos B D} + Definition nf'Pair `{Normalform Shape Pos A} + `{Normalform Shape Pos B} (p : Pair Shape Pos A B) - : Free Shape Pos (Pair Identity.Shape Identity.Pos C D) + : Free Shape Pos (Pair Identity.Shape Identity.Pos + (@nType Shape Pos A _) (@nType Shape Pos B _)) := match p with | pair_ fa fb => nf fa >>= fun na => nf fb >>= fun nb => pure (pair_ (pure na) (pure nb)) end. - Global Instance NormalformPair `{Normalform Shape Pos A C} - `{Normalform Shape Pos B D} + Global Instance NormalformPair `{Normalform Shape Pos A} + `{Normalform Shape Pos B} : Normalform Shape Pos (Pair Shape Pos A B) - (Pair Identity.Shape Identity.Pos C D) := { nf' := nf'Pair }. End SecNFPair. diff --git a/base/coq/Prelude/Unit.v b/base/coq/Prelude/Unit.v index a03dedf8..d29969dd 100644 --- a/base/coq/Prelude/Unit.v +++ b/base/coq/Prelude/Unit.v @@ -26,7 +26,7 @@ Notation "'@Tt' Shape Pos" := (@pure Shape Pos unit tt) (* Normalform instance for Unit *) Instance NormalformUnit (Shape : Type) (Pos : Shape -> Type) - : Normalform Shape Pos (Unit Shape Pos) (Unit Identity.Shape Identity.Pos) + : Normalform Shape Pos (Unit Shape Pos) := { nf' := pure }. (* ShareableArgs instance for Unit *) diff --git a/src/lib/FreeC/Backend/Coq/Base.hs b/src/lib/FreeC/Backend/Coq/Base.hs index 514d7fce..a3aa5575 100644 --- a/src/lib/FreeC/Backend/Coq/Base.hs +++ b/src/lib/FreeC/Backend/Coq/Base.hs @@ -9,6 +9,8 @@ module FreeC.Backend.Coq.Base , free , shape , pos + , idShape + , idPos , freePureCon , freeImpureCon , freeBind @@ -35,6 +37,7 @@ module FreeC.Backend.Coq.Base , normalformBinder , nf' , nf + , nType , implicitArg , share , cbneed @@ -94,6 +97,14 @@ pos = Coq.Bare posIdent posIdent :: Coq.Ident posIdent = Coq.ident "Pos" +-- | The Coq identifier for the @Identity@ shape. +idShape :: Coq.Qualid +idShape = Coq.Qualified (Coq.ident "Identity") shapeIdent + +-- | The Coq identifier for the @Identity@ position function. +idPos :: Coq.Qualid +idPos = Coq.Qualified (Coq.ident "Identity") posIdent + -- | The Coq identifier for the @pure@ constructor of the @Free@ monad. freePureCon :: Coq.Qualid freePureCon = Coq.bare "pure" @@ -220,10 +231,10 @@ normalform = Coq.bare "Normalform" -- | The Coq binder for the @Normalform@ type class with the source and target -- type variable with the given names. -normalformBinder :: Coq.Qualid -> Coq.Qualid -> Coq.Binder -normalformBinder sourceType targetType = Coq.Generalized Coq.Implicit +normalformBinder :: Coq.Qualid -> Coq.Binder +normalformBinder sourceType = Coq.Generalized Coq.Implicit $ Coq.app (Coq.Qualid normalform) - $ map Coq.Qualid [shape, pos, sourceType, targetType] + $ map Coq.Qualid [shape, pos, sourceType] -- | The Coq identifier of the @Normalform@ class function. nf' :: Coq.Qualid @@ -233,6 +244,10 @@ nf' = Coq.bare "nf'" nf :: Coq.Qualid nf = Coq.bare "nf" +-- | The Coq identifier for a normalized type. +nType :: Coq.Qualid +nType = Coq.bare "nType" + ------------------------------------------------------------------------------- -- Effect selection -- ------------------------------------------------------------------------------- diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs index 72132936..9842d335 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs @@ -108,6 +108,7 @@ import Data.List ( nub ) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.Strict as Map import Data.Maybe ( fromJust ) +import Language.Coq.Subst import qualified FreeC.Backend.Coq.Base as Coq.Base import FreeC.Backend.Coq.Converter.Free @@ -115,7 +116,6 @@ import qualified FreeC.Backend.Coq.Syntax as Coq import FreeC.Environment import FreeC.Environment.Entry import FreeC.Environment.Fresh - ( freshArgPrefix, freshNormalformArgPrefix, freshSharingArgPrefix, freshTypeVarPrefix, freshCoqQualid, freshHaskellIdent ) import FreeC.Environment.LookupOrFail import FreeC.IR.SrcSpan ( SrcSpan(NoSrcSpan) ) import FreeC.IR.Subst @@ -129,8 +129,10 @@ import FreeC.Pretty -- Instance Generation -- ------------------------------------------------------------------------------- -- | Data type for a type with certain components replaced by underscores. -data StrippedType = StrippedType | StrippedTypeCon IR.TypeConName [StrippedType] - deriving (Eq, Ord, Show) +data StrippedType + = StrippedType + | StrippedTypeCon IR.TypeConName [StrippedType] + deriving ( Eq, Ord, Show ) isStripped :: StrippedType -> Bool isStripped StrippedType = True @@ -138,6 +140,7 @@ isStripped _ = False -- | Type synonym for a map mapping types to function names. type TypeMap' = Map.Map IR.Type Coq.Qualid + type TypeMap = Map.Map StrippedType Coq.Qualid -- | Builds instances for all supported typeclasses. @@ -198,7 +201,10 @@ generateTypeclassInstances dataDecls = do -> Coq.Qualid -> Converter ([Coq.Binder], Coq.Binder, Coq.Term, Coq.Term)) -- ^ A function to get class-specific binders and return types. - -> (TypeMap -> Coq.Qualid -> [(StrippedType, Coq.Qualid)] -> Converter Coq.Term) + -> (TypeMap + -> Coq.Qualid + -> [(StrippedType, Coq.Qualid)] + -> Converter Coq.Term) -- ^ A function to compute a class-specific value given a data constructor -- with arguments. -> Converter [Coq.Sentence] @@ -323,16 +329,19 @@ generateTypeclassInstances dataDecls = do Nothing (Just retType) letBody))) inBody -- | Matches on the constructors of a type. - matchConstructors :: TypeMap -> Coq.Qualid -> StrippedType -> Converter Coq.Term - matchConstructors m varName t@(StrippedTypeCon conName _) = do + matchConstructors + :: TypeMap -> Coq.Qualid -> StrippedType -> Converter Coq.Term + matchConstructors m varName t@(StrippedTypeCon conName _) = do entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName equations <- mapM (buildEquation m t) (entryConsNames entry) return $ Coq.match (Coq.Qualid varName) equations - matchConstructors _ _ StrippedType = error "generateTypeclassInstances: unexpected type placeholder." + matchConstructors _ _ StrippedType + = error "generateTypeclassInstances: unexpected type placeholder." -- | Creates a match equation on a given data constructor with a -- class-specific right-hand side. - buildEquation :: TypeMap -> StrippedType -> IR.ConName -> Converter Coq.Equation + buildEquation + :: TypeMap -> StrippedType -> IR.ConName -> Converter Coq.Equation buildEquation m t conName = do conEntry <- lookupEntryOrFail NoSrcSpan IR.ValueScope conName retType <- expandAllTypeSynonyms (entryReturnType conEntry) @@ -342,14 +351,14 @@ generateTypeclassInstances dataDecls = do conArgIdents <- freshQualids (entryArity conEntry) freshArgPrefix -- Replace all underscores with fresh variables before unification. tFreshVars <- insertFreshVariables t - subst <- unifyOrFail NoSrcSpan tFreshVars retType + sub <- unifyOrFail NoSrcSpan tFreshVars retType -- Find out the type of each constructor argument by unifying its return -- type with the given type expression and applying the resulting -- substitution to each constructor argument's type. -- Then convert all irrelevant components to underscores again so the -- type can be looked up in the type map. expandedArgTypes <- mapM expandAllTypeSynonyms (entryArgTypes conEntry) - let modArgTypes = map (stripType . applySubst subst) expandedArgTypes + let modArgTypes = map (stripType . applySubst sub) expandedArgTypes let lhs = Coq.ArgsPat conIdent (map Coq.QualidPat conArgIdents) -- Build the right-hand side of the equation by applying the -- class-specific function @buildValue@. @@ -371,27 +380,32 @@ generateTypeclassInstances dataDecls = do , Coq.Term -- Return type of the @Normalform@ instance. ) nfBindersAndReturnType t varName = do - -- For each type variable in the type, generate two type variables. - -- One represents the type's variable itself, the other the result - -- type of the normalization. - -- The type is transformed to a Coq type twice, once with @Shape@ and - -- @Pos@ as arguments for the original type, once with @Identity.Shape@ - -- and @Identity.Pos@ as arguments for the normalized result type. - (sourceType, sourceVars) <- toCoqType freshTypeVarPrefix shapeAndPos t - (targetType, targetVars) <- toCoqType freshTypeVarPrefix idShapeAndPos t - -- For each type variable @ai@, build a constraint - -- @`{Normalform Shape Pos ai bi}@. - let constraints = zipWith Coq.Base.normalformBinder sourceVars targetVars - let varBinder - = [typeVarBinder (sourceVars ++ targetVars) | not (null sourceVars)] - let binders = varBinder ++ constraints - -- Create an explicit argument binder for the value to be normalized. - let topLevelVarBinder + (sourceType, sourceVars) <- toCoqType t + -- The return types of the type variables' @Normalform@ instances. + let nTypes = map + (\v -> Coq.explicitApp Coq.Base.nType + (shapeAndPos ++ Coq.Qualid v : [Coq.Underscore])) sourceVars + -- Build a substitution to create the normalized type from the source + -- type. + targetTypeMap = buildNFSubst (zip sourceVars nTypes) + targetType = subst targetTypeMap sourceType + -- For each type variable @aᵢ@, build a constraint + -- @`{Normalform Shape Pos aᵢ}@. + constraints = map Coq.Base.normalformBinder sourceVars + varBinder = [typeVarBinder sourceVars | not (null sourceVars)] + binders = varBinder ++ constraints + -- Create an explicit argument binder for the value to be normalized. + topLevelVarBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit varName sourceType - let instanceRetType = Coq.app (Coq.Qualid Coq.Base.normalform) - (shapeAndPos ++ [sourceType, targetType]) - let funcRetType = applyFree targetType + instanceRetType = Coq.app (Coq.Qualid Coq.Base.normalform) + (shapeAndPos ++ [sourceType]) + funcRetType = applyFree targetType return (binders, topLevelVarBinder, funcRetType, instanceRetType) + where + buildNFSubst :: [(Coq.Qualid, Coq.Term)] -> Map.Map Coq.Qualid Coq.Term + buildNFSubst kvs = Map.insert Coq.Base.shape (Coq.Qualid Coq.Base.idShape) + (Map.insert Coq.Base.pos (Coq.Qualid Coq.Base.idPos) + (foldr (uncurry Map.insert) Map.empty kvs)) -- | Builds a normalized @Free@ value for the given constructor -- and constructor arguments. @@ -436,7 +450,7 @@ generateTypeclassInstances dataDecls = do -- already exists. Therefore, we apply @nf@ to the component to receive -- a normalized value. Nothing -> do - nx <- freshCoqQualid ("n" ++ freshArgPrefix) + nx <- freshCoqQualid freshNormalformArgPrefix rhs <- buildNormalformValue' (nx : boundVars) consVars let c = Coq.fun [nx] [Nothing] rhs return @@ -458,7 +472,7 @@ generateTypeclassInstances dataDecls = do , Coq.Term -- Return type of the @ShareableArgs@ instance. ) shareArgsBindersAndReturnType t varName = do - (coqType, vars) <- toCoqType "a" shapeAndPos t + (coqType, vars) <- toCoqType t let constraints = Coq.Base.injectableBinder : map Coq.Base.shareableArgsBinder vars let varBinder = [typeVarBinder vars | not (null vars)] @@ -508,11 +522,13 @@ generateTypeclassInstances dataDecls = do ------------------------------------------------------------------------------- -- | Creates an entry with a unique name for each of the given types and -- inserts them into the given map. - nameFunctionsAndInsert :: String -> TypeMap -> [StrippedType] -> Converter TypeMap + nameFunctionsAndInsert + :: String -> TypeMap -> [StrippedType] -> Converter TypeMap nameFunctionsAndInsert prefix = foldM (nameFunctionAndInsert prefix) -- | Like 'nameFunctionsAndInsert', but for a single type. - nameFunctionAndInsert :: String -> TypeMap -> StrippedType -> Converter TypeMap + nameFunctionAndInsert + :: String -> TypeMap -> StrippedType -> Converter TypeMap nameFunctionAndInsert prefix m t = do name <- nameFunction prefix t return (Map.insert t name m) @@ -575,36 +591,37 @@ generateTypeclassInstances dataDecls = do -- If not, check if a relevant type occurs in its left-hand side, -- otherwise replace the whole expression with an underscore. StrippedType -> case stripType' flag l of - StrippedType -> StrippedType - StrippedTypeCon con args -> StrippedTypeCon con (args ++ [StrippedType]) + StrippedType -> StrippedType + StrippedTypeCon con args -> StrippedTypeCon con (args ++ [StrippedType]) -- If a relevant type does occur in the right-hand side, -- the type application must be preserved, so only its arguments are -- stripped. - r' -> let StrippedTypeCon con args = stripType' True l in StrippedTypeCon con (args ++ [r']) + r' -> let StrippedTypeCon con args = stripType' True l + in StrippedTypeCon con (args ++ [r']) -- Type variables and function types are not relevant and are replaced by @_@. stripType' _ _ = StrippedType showPrettyType :: StrippedType -> Converter String + -- For a placeholder, show "_". - showPrettyType StrippedType = return "_" + showPrettyType StrippedType = return "_" -- For a type constructor and its arguments, return the constructor's -- Coq identifier as a string with the conversions of the arguments appended. showPrettyType (StrippedTypeCon con args) = do - prettyCon <- fromJust . (>>= Coq.unpackQualid) - <$> inEnv (lookupIdent IR.TypeScope con) - prettyArgs <- concatMapM showPrettyType args - return (prettyCon ++ prettyArgs) - + prettyCon <- fromJust . (>>= Coq.unpackQualid) + <$> inEnv (lookupIdent IR.TypeScope con) + prettyArgs <- concatMapM showPrettyType args + return (prettyCon ++ prettyArgs) -- | Converts a @StrippedType@ to an @IR.Type@, replacing all -- placeholders with fresh variables. insertFreshVariables :: StrippedType -> Converter IR.Type - insertFreshVariables StrippedType = do - freshVar <- freshHaskellIdent freshArgPrefix - return (IR.TypeVar NoSrcSpan freshVar) + insertFreshVariables StrippedType = do + freshVar <- freshHaskellIdent freshArgPrefix + return (IR.TypeVar NoSrcSpan freshVar) insertFreshVariables (StrippedTypeCon con args) = do - args' <- mapM insertFreshVariables args - return (foldl (IR.TypeApp NoSrcSpan) (IR.TypeCon NoSrcSpan con) args') + args' <- mapM insertFreshVariables args + return (foldl (IR.TypeApp NoSrcSpan) (IR.TypeCon NoSrcSpan con) args') -- | Binders for (implicit) Shape and Pos arguments. -- @@ -631,49 +648,23 @@ generateTypeclassInstances dataDecls = do shapeAndPos :: [Coq.Term] shapeAndPos = [Coq.Qualid Coq.Base.shape, Coq.Qualid Coq.Base.pos] - -- | The shape and position function arguments for the identity monad - -- as a Coq term. - idShapeAndPos :: [Coq.Term] - idShapeAndPos = map Coq.Qualid - [ Coq.Qualified (Coq.ident "Identity") Coq.Base.shapeIdent - , Coq.Qualified (Coq.ident "Identity") Coq.Base.posIdent - ] - - -- | Converts a type into a Coq type (a term) with the specified - -- additional arguments (for example @Shape@ and @Pos@) and fresh Coq + -- | Converts a type into a Coq type (a term) with fresh Coq -- identifiers for all underscores. -- Returns a pair of the result term and a list of the fresh variables. - toCoqType - :: String -- ^ The prefix of the fresh variables. - -> [Coq.Term] -- ^ A list of additional arguments, e.g. Shape and Pos. - -> StrippedType -- ^ The type to convert. - -> Converter (Coq.Term, [Coq.Qualid]) + toCoqType :: StrippedType -- ^ The type to convert. + -> Converter (Coq.Term, [Coq.Qualid]) -- A type variable is translated into a fresh type variable. - toCoqType varPrefix _ StrippedType = do - x <- freshCoqQualid varPrefix + toCoqType StrippedType = do + x <- freshCoqQualid freshTypeVarPrefix return (Coq.Qualid x, [x]) - toCoqType varPrefix extraArgs (StrippedTypeCon con args) = do - entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope con - (coqArgs,freshVars) <- mapAndUnzipM (toCoqType varPrefix extraArgs) args - return (Coq.app (Coq.Qualid (entryIdent entry)) (extraArgs ++ coqArgs), concat freshVars ) - - - {- - -- A type constructor is applied to the given arguments. - toCoqType _ extraArgs (IR.TypeCon _ conName) = do - entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope conName - return (Coq.app (Coq.Qualid (entryIdent entry)) extraArgs, []) - -- For a type application, both arguments are translated recursively - -- and the collected variables are combined. - toCoqType varPrefix extraArgs (IR.TypeApp _ l r) = do - (l', varsl) <- toCoqType varPrefix extraArgs l - (r', varsr) <- toCoqType varPrefix extraArgs r - return (Coq.app l' [r'], varsl ++ varsr) - -- Function types were removed by 'stripType'. - toCoqType _ _ (IR.FuncType _ _ _) - = error "Function types should have been eliminated." - -} + toCoqType (StrippedTypeCon con args) = do + entry <- lookupEntryOrFail NoSrcSpan IR.TypeScope con + (coqArgs, freshVars) <- mapAndUnzipM toCoqType args + return ( Coq.app (Coq.Qualid (entryIdent entry)) (shapeAndPos ++ coqArgs) + , concat freshVars + ) + -- | Produces @n@ new Coq identifiers (Qualids) with the same prefix. freshQualids :: Int -> String -> Converter [Coq.Qualid] freshQualids n prefix = replicateM n (freshCoqQualid prefix) diff --git a/src/lib/FreeC/Environment/Fresh.hs b/src/lib/FreeC/Environment/Fresh.hs index 893bfd8f..06fc8c08 100644 --- a/src/lib/FreeC/Environment/Fresh.hs +++ b/src/lib/FreeC/Environment/Fresh.hs @@ -48,11 +48,11 @@ freshArgPrefix = "x" -- | The prefix to use for variables artificially introduced by normalization. freshNormalformArgPrefix :: String -freshSharingArgPrefix = "nx" +freshNormalformArgPrefix = "nx" -- | The prefix to use for variables artificially introduced by sharing. freshSharingArgPrefix :: String -freshNormalformArgPrefix = "sx" +freshSharingArgPrefix = "sx" -- | The prefix to use for artificially introduced variables of type @a -> b@. freshFuncPrefix :: String diff --git a/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs b/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs index 1db65e74..5f856863 100644 --- a/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs +++ b/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs @@ -116,14 +116,16 @@ testConvertTypeDecl ++ " (* Normalform instance for Tree *) " ++ "Fixpoint nf'Tree_" ++ " {Shape : Type} {Pos : Shape -> Type} " - ++ " {a b : Type} `{Normalform Shape Pos a b} " + ++ " {a : Type} `{Normalform Shape Pos a} " ++ " (x : Tree Shape Pos a) " - ++ " : Free Shape Pos (Tree Identity.Shape Identity.Pos b) " + ++ " : Free Shape Pos" + ++ " (Tree Identity.Shape Identity.Pos (@nType Shape Pos a _))" ++ " := let fix nf'ListTree_" - ++ " {a0 b0 : Type} `{Normalform Shape Pos a0 b0} " + ++ " {a0 : Type} `{Normalform Shape Pos a0} " ++ " (x1 : List Shape Pos (Tree Shape Pos a0)) " ++ " : Free Shape Pos (List Identity.Shape Identity.Pos " - ++ " (Tree Identity.Shape Identity.Pos b0))" + ++ " (Tree Identity.Shape Identity.Pos" + ++ " (@nType Shape Pos a0 _)))" ++ " := match x1 with " ++ " | nil => pure nil " ++ " | cons fx1 fx2 =>" @@ -142,9 +144,8 @@ testConvertTypeDecl ++ " end. " ++ "Instance NormalformTree_" ++ " {Shape : Type} {Pos : Shape -> Type}" - ++ " {a b : Type} `{Normalform Shape Pos a b}" + ++ " {a : Type} `{Normalform Shape Pos a}" ++ " : Normalform Shape Pos (Tree Shape Pos a)" - ++ " (Tree Identity.Shape Identity.Pos b)" ++ " := { nf' := nf'Tree_ }. " ++ "(* ShareableArgs instance for Tree *) " ++ "Fixpoint shareArgsTree_" @@ -231,7 +232,6 @@ testConvertTypeDecl ++ "Instance NormalformFoo" ++ " {Shape : Type} {Pos : Shape -> Type}" ++ " : Normalform Shape Pos (Foo Shape Pos)" - ++ " (Foo Identity.Shape Identity.Pos)" ++ " := { nf' := nf'Foo }. " ++ "(* ShareableArgs instance for Foo *) " ++ "Fixpoint shareArgsFoo" @@ -315,7 +315,6 @@ testConvertDataDecls ++ "Instance NormalformFoo" ++ " {Shape : Type} {Pos : Shape -> Type}" ++ " : Normalform Shape Pos (Foo Shape Pos)" - ++ " (Foo Identity.Shape Identity.Pos)" ++ " := { nf' := nf'Foo }. " ++ "(* ShareableArgs instance for Foo *) " ++ "Fixpoint shareArgsFoo" @@ -370,19 +369,20 @@ testConvertDataDecls ++ "(* Normalform instance for Foo *) " ++ "Fixpoint nf'Foo__" ++ " {Shape : Type} {Pos : Shape -> Type}" - ++ " {a a0 b b0 : Type} `{Normalform Shape Pos a b}" - ++ " `{Normalform Shape Pos a0 b0} (x : Foo Shape Pos a a0)" - ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos b b0)" + ++ " {a a0 : Type} `{Normalform Shape Pos a}" + ++ " `{Normalform Shape Pos a0} (x : Foo Shape Pos a a0)" + ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos" + ++ " (@nType Shape Pos a _)" + ++ " (@nType Shape Pos a0 _))" ++ " := match x with" ++ " | bar fx => nf fx >>= (fun nx => pure (bar (pure nx)))" ++ " | baz fx0 => nf fx0 >>= (fun nx0 => pure (baz (pure nx0)))" ++ " end. " ++ "Instance NormalformFoo__" ++ " {Shape : Type} {Pos : Shape -> Type}" - ++ " {a a0 b b0 : Type} `{Normalform Shape Pos a b}" - ++ " `{Normalform Shape Pos a0 b0}" + ++ " {a a0 : Type} `{Normalform Shape Pos a}" + ++ " `{Normalform Shape Pos a0}" ++ " : Normalform Shape Pos (Foo Shape Pos a a0)" - ++ " (Foo Identity.Shape Identity.Pos b b0)" ++ " := { nf' := nf'Foo__ }. " ++ "(* ShareableArgs instance for Foo *) " ++ "Fixpoint shareArgsFoo__" @@ -435,7 +435,6 @@ testConvertDataDecls ++ "Instance NormalformFoo" ++ " {Shape : Type} {Pos : Shape -> Type}" ++ " : Normalform Shape Pos (Foo Shape Pos)" - ++ " (Foo Identity.Shape Identity.Pos)" ++ " := { nf' := nf'Foo }. " ++ "(* ShareableArgs instance for Foo *) " ++ "Fixpoint shareArgsFoo" @@ -478,16 +477,16 @@ testConvertDataDecls ++ "(* Normalform instance for Foo *) " ++ "Fixpoint nf'Foo_" ++ " {Shape : Type} {Pos : Shape -> Type}" - ++ " {a0 b : Type} `{Normalform Shape Pos a0 b}" + ++ " {a0 : Type} `{Normalform Shape Pos a0}" ++ " (x : Foo Shape Pos a0)" - ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos b)" + ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos" + ++ " (@nType Shape Pos a0 _))" ++ " := let 'a fx := x" ++ " in nf fx >>= (fun nx => pure (a (pure nx))). " ++ "Instance NormalformFoo_" ++ " {Shape : Type} {Pos : Shape -> Type}" - ++ " {a0 b : Type} `{Normalform Shape Pos a0 b}" + ++ " {a0 : Type} `{Normalform Shape Pos a0}" ++ " : Normalform Shape Pos (Foo Shape Pos a0)" - ++ " (Foo Identity.Shape Identity.Pos b)" ++ " := { nf' := nf'Foo_ }. " ++ "(* ShareableArgs instance for Foo *) " ++ "Fixpoint shareArgsFoo_" @@ -566,12 +565,10 @@ testConvertDataDecls ++ "Instance NormalformFoo" ++ " {Shape : Type} {Pos : Shape -> Type} " ++ " : Normalform Shape Pos (Foo Shape Pos) " - ++ " (Foo Identity.Shape Identity.Pos)" ++ " := { nf' := nf'Foo }. " ++ "Instance NormalformBar" ++ " {Shape : Type} {Pos : Shape -> Type}" ++ " : Normalform Shape Pos (Bar Shape Pos)" - ++ " (Bar Identity.Shape Identity.Pos)" ++ " := { nf' := nf'Bar }. " ++ "(* ShareableArgs instances for Foo, Bar *) " ++ "Fixpoint shareArgsFoo" @@ -639,9 +636,10 @@ testConvertDataDecls ++ " Shape, Pos, a, x, x0, x1 at level 9 ). " ++ "(* Normalform instance for Foo *) " ++ "Fixpoint nf'Foo_" - ++ " {Shape : Type} {Pos : Shape -> Type} {a b : Type}" - ++ " `{Normalform Shape Pos a b} (x : Foo Shape Pos a) " - ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos b) " + ++ " {Shape : Type} {Pos : Shape -> Type} {a : Type}" + ++ " `{Normalform Shape Pos a} (x : Foo Shape Pos a) " + ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos" + ++ " (@nType Shape Pos a _)) " ++ " := let 'foo fx fx0 fx1 := x" ++ " in fx >>= (fun x0 => " ++ " nf'Foo_ x0 >>= (fun nx =>" @@ -651,9 +649,8 @@ testConvertDataDecls ++ " pure (foo (pure nx) (pure nx0) (pure nx1))))))). " ++ "Instance NormalformFoo_" ++ " {Shape : Type} {Pos : Shape -> Type}" - ++ " {a b : Type} `{Normalform Shape Pos a b}" + ++ " {a : Type} `{Normalform Shape Pos a}" ++ " : Normalform Shape Pos (Foo Shape Pos a)" - ++ " (Foo Identity.Shape Identity.Pos b)" ++ " := { nf' := nf'Foo_ }. " ++ "(* ShareableArgs instance for Foo *) " ++ "Fixpoint shareArgsFoo_" From 29d2a94f71c3c284bace0bc90300207bb34eb6f2 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 28 Sep 2020 10:56:45 +0200 Subject: [PATCH 099/120] Adjust TypeDeclTests #150 --- .../Backend/Coq/Converter/TypeDeclTests.hs | 108 +++++++++--------- 1 file changed, 54 insertions(+), 54 deletions(-) diff --git a/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs b/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs index 5f856863..f106d688 100644 --- a/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs +++ b/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs @@ -122,24 +122,24 @@ testConvertTypeDecl ++ " (Tree Identity.Shape Identity.Pos (@nType Shape Pos a _))" ++ " := let fix nf'ListTree_" ++ " {a0 : Type} `{Normalform Shape Pos a0} " - ++ " (x1 : List Shape Pos (Tree Shape Pos a0)) " + ++ " (x3 : List Shape Pos (Tree Shape Pos a0)) " ++ " : Free Shape Pos (List Identity.Shape Identity.Pos " ++ " (Tree Identity.Shape Identity.Pos" ++ " (@nType Shape Pos a0 _)))" - ++ " := match x1 with " + ++ " := match x3 with " ++ " | nil => pure nil " - ++ " | cons fx1 fx2 =>" - ++ " fx1 >>= (fun x2 =>" - ++ " nf'Tree_ x2 >>= (fun nx1 =>" - ++ " fx2 >>= (fun x3 =>" - ++ " nf'ListTree_ x3 >>= (fun nx2 =>" + ++ " | cons x4 x5 =>" + ++ " x4 >>= (fun x6 =>" + ++ " nf'Tree_ x6 >>= (fun nx1 =>" + ++ " x5 >>= (fun x7 =>" + ++ " nf'ListTree_ x7 >>= (fun nx2 =>" ++ " pure (cons (pure nx1) (pure nx2))))))" ++ " end " ++ " in match x with " - ++ " | leaf fx => nf fx >>= (fun nx =>" + ++ " | leaf x0 => nf x0 >>= (fun nx =>" ++ " pure (leaf (pure nx)))" - ++ " | branch fx0 => fx0 >>= (fun x0 => " - ++ " nf'ListTree_ x0 >>= (fun nx0 =>" + ++ " | branch x1 => x1 >>= (fun x2 => " + ++ " nf'ListTree_ x2 >>= (fun nx0 =>" ++ " pure (branch (pure nx0))))" ++ " end. " ++ "Instance NormalformTree_" @@ -157,21 +157,21 @@ testConvertTypeDecl ++ " {a0 : Type}" ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" ++ " `{ShareableArgs Shape Pos a0}" - ++ " (x0 : List Shape Pos (Tree Shape Pos a0))" + ++ " (x2 : List Shape Pos (Tree Shape Pos a0))" ++ " : Free Shape Pos (List Shape Pos (Tree Shape Pos a0))" - ++ " := match x0 with " + ++ " := match x2 with " ++ " | nil => pure nil " - ++ " | cons fx1 fx2 => " - ++ " cbneed Shape Pos shareArgsTree_ fx1 >>= (fun sx1 =>" - ++ " cbneed Shape Pos shareArgsListTree_ fx2 >>=" + ++ " | cons x3 x4 => " + ++ " cbneed Shape Pos shareArgsTree_ x3 >>= (fun sx1 =>" + ++ " cbneed Shape Pos shareArgsListTree_ x4 >>=" ++ " (fun sx2 => " ++ " pure (cons sx1 sx2))) " ++ " end " ++ " in match x with " - ++ " | leaf fx => cbneed Shape Pos shareArgs fx >>= (fun sx =>" + ++ " | leaf x0 => cbneed Shape Pos shareArgs x0 >>= (fun sx =>" ++ " pure (leaf sx)) " - ++ " | branch fx0 => " - ++ " cbneed Shape Pos shareArgsListTree_ fx0 >>=" + ++ " | branch x1 => " + ++ " cbneed Shape Pos shareArgsListTree_ x1 >>=" ++ " (fun sx0 =>" ++ " pure (branch sx0)) " ++ " end. " @@ -223,11 +223,11 @@ testConvertTypeDecl ++ " {Shape : Type} {Pos : Shape -> Type} " ++ " (x : Foo Shape Pos) " ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos) " - ++ " := let 'foo fx fx0 := x" - ++ " in fx >>= (fun x0 =>" - ++ " nf'Foo x0 >>= (fun nx =>" - ++ " fx0 >>= (fun x1 =>" - ++ " nf'Foo x1 >>= (fun nx0 =>" + ++ " := let 'foo x0 x1 := x" + ++ " in x0 >>= (fun x2 =>" + ++ " nf'Foo x2 >>= (fun nx =>" + ++ " x1 >>= (fun x3 =>" + ++ " nf'Foo x3 >>= (fun nx0 =>" ++ " pure (foo (pure nx) (pure nx0)))))). " ++ "Instance NormalformFoo" ++ " {Shape : Type} {Pos : Shape -> Type}" @@ -239,9 +239,9 @@ testConvertTypeDecl ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" ++ " (x : Foo Shape Pos) " ++ " : Free Shape Pos (Foo Shape Pos)" - ++ " := let 'foo fx fx0 := x" - ++ " in cbneed Shape Pos shareArgsFoo fx >>= (fun sx =>" - ++ " cbneed Shape Pos shareArgsFoo fx0 >>= (fun sx0 =>" + ++ " := let 'foo x0 x1 := x" + ++ " in cbneed Shape Pos shareArgsFoo x0 >>= (fun sx =>" + ++ " cbneed Shape Pos shareArgsFoo x1 >>= (fun sx0 =>" ++ " pure (foo sx sx0))). " ++ "Instance ShareableArgsFoo" ++ " {Shape : Type} {Pos : Shape -> Type}" @@ -375,8 +375,8 @@ testConvertDataDecls ++ " (@nType Shape Pos a _)" ++ " (@nType Shape Pos a0 _))" ++ " := match x with" - ++ " | bar fx => nf fx >>= (fun nx => pure (bar (pure nx)))" - ++ " | baz fx0 => nf fx0 >>= (fun nx0 => pure (baz (pure nx0)))" + ++ " | bar x0 => nf x0 >>= (fun nx => pure (bar (pure nx)))" + ++ " | baz x1 => nf x1 >>= (fun nx0 => pure (baz (pure nx0)))" ++ " end. " ++ "Instance NormalformFoo__" ++ " {Shape : Type} {Pos : Shape -> Type}" @@ -392,9 +392,9 @@ testConvertDataDecls ++ " (x : Foo Shape Pos a a0)" ++ " : Free Shape Pos (Foo Shape Pos a a0)" ++ " := match x with" - ++ " | bar fx => cbneed Shape Pos shareArgs fx >>= (fun sx =>" + ++ " | bar x0 => cbneed Shape Pos shareArgs x0 >>= (fun sx =>" ++ " pure (bar sx))" - ++ " | baz fx0 => cbneed Shape Pos shareArgs fx0 >>= (fun sx0 =>" + ++ " | baz x1 => cbneed Shape Pos shareArgs x1 >>= (fun sx0 =>" ++ " pure (baz sx0))" ++ " end. " ++ "Instance ShareableArgsFoo__" @@ -481,8 +481,8 @@ testConvertDataDecls ++ " (x : Foo Shape Pos a0)" ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos" ++ " (@nType Shape Pos a0 _))" - ++ " := let 'a fx := x" - ++ " in nf fx >>= (fun nx => pure (a (pure nx))). " + ++ " := let 'a x0 := x" + ++ " in nf x0 >>= (fun nx => pure (a (pure nx))). " ++ "Instance NormalformFoo_" ++ " {Shape : Type} {Pos : Shape -> Type}" ++ " {a0 : Type} `{Normalform Shape Pos a0}" @@ -494,8 +494,8 @@ testConvertDataDecls ++ " `{Injectable Share.Shape Share.Pos Shape Pos} " ++ " `{ShareableArgs Shape Pos a0} (x : Foo Shape Pos a0) " ++ " : Free Shape Pos (Foo Shape Pos a0)" - ++ " := let 'a fx := x" - ++ " in cbneed Shape Pos shareArgs fx >>= (fun sx =>" + ++ " := let 'a x0 := x" + ++ " in cbneed Shape Pos shareArgs x0 >>= (fun sx =>" ++ " pure (a sx)). " ++ "Instance ShareableArgsFoo_" ++ " {Shape : Type} {Pos : Shape -> Type} {a0 : Type}" @@ -552,15 +552,15 @@ testConvertDataDecls ++ " {Shape : Type} {Pos : Shape -> Type}" ++ " (x : Foo Shape Pos)" ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos)" - ++ " := let 'foo fx := x" - ++ " in fx >>= (fun x0 =>" - ++ " nf'Bar x0 >>= (fun nx => pure (foo (pure nx)))) " + ++ " := let 'foo x0 := x" + ++ " in x0 >>= (fun x1 =>" + ++ " nf'Bar x1 >>= (fun nx => pure (foo (pure nx)))) " ++ "with nf'Bar" ++ " {Shape : Type} {Pos : Shape -> Type} (x : Bar Shape Pos)" ++ " : Free Shape Pos (Bar Identity.Shape Identity.Pos)" - ++ " := let 'bar fx := x" - ++ " in fx >>= (fun x0 =>" - ++ " nf'Foo x0 >>= (fun nx =>" + ++ " := let 'bar x0 := x" + ++ " in x0 >>= (fun x1 =>" + ++ " nf'Foo x1 >>= (fun nx =>" ++ " pure (bar (pure nx)))). " ++ "Instance NormalformFoo" ++ " {Shape : Type} {Pos : Shape -> Type} " @@ -576,8 +576,8 @@ testConvertDataDecls ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" ++ " (x : Foo Shape Pos) " ++ " : Free Shape Pos (Foo Shape Pos)" - ++ " := let 'foo fx := x" - ++ " in cbneed Shape Pos shareArgsBar fx >>= (fun sx =>" + ++ " := let 'foo x0 := x" + ++ " in cbneed Shape Pos shareArgsBar x0 >>= (fun sx =>" ++ " pure (foo sx)) " ++ "with " ++ "shareArgsBar" @@ -585,8 +585,8 @@ testConvertDataDecls ++ " `{Injectable Share.Shape Share.Pos Shape Pos}" ++ " (x : Bar Shape Pos)" ++ " : Free Shape Pos (Bar Shape Pos)" - ++ " := let 'bar fx := x" - ++ " in cbneed Shape Pos shareArgsFoo fx >>= (fun sx =>" + ++ " := let 'bar x0 := x" + ++ " in cbneed Shape Pos shareArgsFoo x0 >>= (fun sx =>" ++ " pure (bar sx)). " ++ "Instance ShareableArgsFoo" ++ " {Shape : Type} {Pos : Shape -> Type}" @@ -640,12 +640,12 @@ testConvertDataDecls ++ " `{Normalform Shape Pos a} (x : Foo Shape Pos a) " ++ " : Free Shape Pos (Foo Identity.Shape Identity.Pos" ++ " (@nType Shape Pos a _)) " - ++ " := let 'foo fx fx0 fx1 := x" - ++ " in fx >>= (fun x0 => " - ++ " nf'Foo_ x0 >>= (fun nx =>" - ++ " nf fx0 >>= (fun nx0 =>" - ++ " fx1 >>= (fun x1 =>" - ++ " nf'Foo_ x1 >>= (fun nx1 =>" + ++ " := let 'foo x0 x1 x2 := x" + ++ " in x0 >>= (fun x3 => " + ++ " nf'Foo_ x3 >>= (fun nx =>" + ++ " nf x1 >>= (fun nx0 =>" + ++ " x2 >>= (fun x4 =>" + ++ " nf'Foo_ x4 >>= (fun nx1 =>" ++ " pure (foo (pure nx) (pure nx0) (pure nx1))))))). " ++ "Instance NormalformFoo_" ++ " {Shape : Type} {Pos : Shape -> Type}" @@ -658,10 +658,10 @@ testConvertDataDecls ++ " `{Injectable Share.Shape Share.Pos Shape Pos} " ++ " `{ShareableArgs Shape Pos a} (x : Foo Shape Pos a) " ++ " : Free Shape Pos (Foo Shape Pos a)" - ++ " := let 'foo fx fx0 fx1 := x " - ++ " in cbneed Shape Pos shareArgsFoo_ fx >>= (fun sx =>" - ++ " cbneed Shape Pos shareArgs fx0 >>= (fun sx0 =>" - ++ " cbneed Shape Pos shareArgsFoo_ fx1 >>= (fun sx1 =>" + ++ " := let 'foo x0 x1 x2 := x " + ++ " in cbneed Shape Pos shareArgsFoo_ x0 >>= (fun sx =>" + ++ " cbneed Shape Pos shareArgs x1 >>= (fun sx0 =>" + ++ " cbneed Shape Pos shareArgsFoo_ x2 >>= (fun sx1 =>" ++ " pure (foo sx sx0 sx1)))). " ++ "Instance ShareableArgsFoo_" ++ " {Shape : Type} {Pos : Shape -> Type} {a : Type}" From 90de42e512013c56513c8f39d1ece00b44507494 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 28 Sep 2020 11:17:53 +0200 Subject: [PATCH 100/120] Remove second type variable from Handlers #150 --- base/coq/Free/Handlers.v | 132 +++++++++++++++++++-------------------- 1 file changed, 66 insertions(+), 66 deletions(-) diff --git a/base/coq/Free/Handlers.v b/base/coq/Free/Handlers.v index 2992e6cf..dbc54778 100644 --- a/base/coq/Free/Handlers.v +++ b/base/coq/Free/Handlers.v @@ -18,9 +18,9 @@ Require Import Coq.Lists.List. Section NoEffect. (* Identity handler *) - Definition handleNoEffect {A B : Type} - `{Normalform _ _ A B} - (p : Free Identity.Shape Identity.Pos A) : B + Definition handleNoEffect {A : Type} + `{Normalform _ _ A} + (p : Free Identity.Shape Identity.Pos A) := run (nf p). End NoEffect. @@ -32,19 +32,19 @@ Section OneEffect. Definition SMId := Comb.Shape Maybe.Shape Identity.Shape. Definition PMId := Comb.Pos Maybe.Pos Identity.Pos. - Definition handleMaybe {A B : Type} - `{Normalform SMId PMId A B} + Definition handleMaybe {A : Type} + `{Normalform SMId PMId A} (p : Free SMId PMId A) - : option B := run (runMaybe (nf p)). + : option nType := run (runMaybe (nf p)). (* Error :+: Identity handler *) Definition SErrId := Comb.Shape (Error.Shape string) Identity.Shape. Definition PErrId := Comb.Pos (@Error.Pos string) Identity.Pos. - Definition handleError {A B : Type} - `{Normalform SErrId PErrId A B} - (p : Free SErrId PErrId A) : (B + string) + Definition handleError {A : Type} + `{Normalform SErrId PErrId A} + (p : Free SErrId PErrId A) : (nType + string) := run (runError (nf p)). @@ -52,9 +52,9 @@ Section OneEffect. Definition SNDId := Comb.Shape ND.Shape Identity.Shape. Definition PNDId := Comb.Pos ND.Pos Identity.Pos. - Definition handleND {A B : Type} - `{Normalform SNDId PNDId A B} - (p : Free SNDId PNDId A) : list B + Definition handleND {A : Type} + `{Normalform SNDId PNDId A} + (p : Free SNDId PNDId A) : list nType := collectVals (run (runChoice (nf p))). (* Trace :+: Identity handler *) @@ -62,10 +62,10 @@ Section OneEffect. Definition STrcId := Comb.Shape Trace.Shape Identity.Shape. Definition PTrcId := Comb.Pos Trace.Pos Identity.Pos. - Definition handleTrace {A B : Type} - `{Normalform STrcId PTrcId A B} + Definition handleTrace {A : Type} + `{Normalform STrcId PTrcId A} (p : Free STrcId PTrcId A) - : (B * list string) := + : (nType * list string) := collectMessages (run (runTracing (nf p))). (* Share :+: Identity handler *) @@ -73,9 +73,9 @@ Section OneEffect. Definition SShrId := Comb.Shape Share.Shape Identity.Shape. Definition PShrId := Comb.Pos Share.Pos Identity.Pos. - Definition handleShare {A B : Type} - `{Normalform SShrId PShrId A B} - (p : Free SShrId PShrId A) : B := + Definition handleShare {A : Type} + `{Normalform SShrId PShrId A} + (p : Free SShrId PShrId A) : nType := run (runEmptySharing (0,0) (nf p)). End OneEffect. @@ -92,9 +92,9 @@ Section TwoEffects. Definition PShrND := Comb.Pos Share.Pos (Comb.Pos ND.Pos Identity.Pos). - Definition handleShareND {A B : Type} - `{Normalform SShrND PShrND A B} - (p : Free SShrND PShrND A) : (list B) + Definition handleShareND {A : Type} + `{Normalform SShrND PShrND A} + (p : Free SShrND PShrND A) : (list nType) := collectVals (run (runChoice (runNDSharing (0,0) (nf p)))). (* Share :+: Trace :+: Identity handler *) @@ -103,10 +103,10 @@ Section TwoEffects. Definition PShrTrc := Comb.Pos Share.Pos (Comb.Pos Trace.Pos Identity.Pos). - Definition handleShareTrace {A B : Type} - `{Normalform SShrTrc PShrTrc A B} + Definition handleShareTrace {A : Type} + `{Normalform SShrTrc PShrTrc A} (p : Free SShrTrc PShrTrc A) - : (B * list string) := + : (nType * list string) := collectMessages (run (runTracing (runTraceSharing (0,0) (nf p)))). (* Share :+: Maybe :+: Identity handler *) @@ -114,9 +114,9 @@ Section TwoEffects. Definition SShrMaybe := Comb.Shape Share.Shape (Comb.Shape Maybe.Shape Identity.Shape). Definition PShrMaybe := Comb.Pos Share.Pos (Comb.Pos Maybe.Pos Identity.Pos). - Definition handleShareMaybe {A B : Type} - `{Normalform SShrMaybe PShrMaybe A B} - (p : Free SShrMaybe PShrMaybe A) : option B := + Definition handleShareMaybe {A : Type} + `{Normalform SShrMaybe PShrMaybe A} + (p : Free SShrMaybe PShrMaybe A) : option nType := run (runMaybe (runEmptySharing (0,0) (nf p))). (* ND :+: Maybe :+: Identity handler *) @@ -124,10 +124,10 @@ Section TwoEffects. Definition SNDMaybe := Comb.Shape ND.Shape (Comb.Shape Maybe.Shape Identity.Shape). Definition PNDMaybe := Comb.Pos ND.Pos (Comb.Pos Maybe.Pos Identity.Pos). - Definition handleNDMaybe {A B : Type} - `{Normalform SNDMaybe PNDMaybe A B} + Definition handleNDMaybe {A : Type} + `{Normalform SNDMaybe PNDMaybe A} (p : Free SNDMaybe PNDMaybe A) - : option (list B) := match run (runMaybe (runChoice (nf p))) with + : option (list nType) := match run (runMaybe (runChoice (nf p))) with | None => None | Some t => Some (collectVals t) end. @@ -137,10 +137,10 @@ Section TwoEffects. Definition SMaybeTrc := Comb.Shape Maybe.Shape (Comb.Shape Trace.Shape Identity.Shape). Definition PMaybeTrc := Comb.Pos Maybe.Pos (Comb.Pos Trace.Pos Identity.Pos). - Definition handleMaybeTrace {A B : Type} - `{Normalform SMaybeTrc PMaybeTrc A B} + Definition handleMaybeTrace {A : Type} + `{Normalform SMaybeTrc PMaybeTrc A} (p : Free SMaybeTrc PMaybeTrc A) - : option B * list string := + : option nType * list string := collectMessages (run (runTracing (runMaybe (nf p)))). (* Share :+: Error :+: Identity handler *) @@ -148,9 +148,9 @@ Section TwoEffects. Definition SShrErr := Comb.Shape Share.Shape (Comb.Shape (Error.Shape string) Identity.Shape). Definition PShrErr := Comb.Pos Share.Pos (Comb.Pos (@Error.Pos string) Identity.Pos). - Definition handleShareError {A B : Type} - `{Normalform SShrErr PShrErr A B} - (p : Free SShrErr PShrErr A) : (B + string) + Definition handleShareError {A : Type} + `{Normalform SShrErr PShrErr A} + (p : Free SShrErr PShrErr A) : (nType + string) := run (runError (runEmptySharing (0,0) (nf p))). @@ -159,9 +159,9 @@ Section TwoEffects. Definition SNDErr := Comb.Shape ND.Shape (Comb.Shape (Error.Shape string) Identity.Shape). Definition PNDErr := Comb.Pos ND.Pos (Comb.Pos (@Error.Pos string) Identity.Pos). - Definition handleNDError {A B : Type} - `{Normalform SNDErr PNDErr A B} - (p : Free SNDErr PNDErr A) : list B + string + Definition handleNDError {A : Type} + `{Normalform SNDErr PNDErr A} + (p : Free SNDErr PNDErr A) : list nType + string := match run (runError (runChoice (nf p))) with | inl t => inl (collectVals t) | inr e => inr e @@ -175,10 +175,10 @@ Section TwoEffects. Definition SErrorTrc := Comb.Shape (Error.Shape string) (Comb.Shape Trace.Shape Identity.Shape). Definition PErrorTrc := Comb.Pos (@Error.Pos string) (Comb.Pos Trace.Pos Identity.Pos). - Definition handleErrorTrc {A B : Type} - `{Normalform SErrorTrc PErrorTrc A B} + Definition handleErrorTrc {A : Type} + `{Normalform SErrorTrc PErrorTrc A} (p : Free SErrorTrc PErrorTrc A) - : (B + string) * list string + : (nType + string) * list string := collectMessages (run (runTracing (runError (nf p)))). (* Trace :+: ND :+: Identity handler *) @@ -186,12 +186,12 @@ Section TwoEffects. Definition STrcND := Comb.Shape Trace.Shape (Comb.Shape ND.Shape Identity.Shape). Definition PTrcND := Comb.Pos Trace.Pos (Comb.Pos ND.Pos Identity.Pos). - Definition handleTraceND {A B : Type} - `{Normalform STrcND PTrcND A B} + Definition handleTraceND {A : Type} + `{Normalform STrcND PTrcND A} (p : Free STrcND PTrcND A) - : list (B * list string) := - map (@collectMessages B) - (@collectVals (B * list (option Sharing.ID * string)) + : list (nType * list string) := + map (@collectMessages nType) + (@collectVals (nType * list (option Sharing.ID * string)) (run (runChoice (runTracing (nf p))))). End TwoEffects. @@ -214,13 +214,13 @@ Section ThreeEffects. (Comb.Pos ND.Pos (Comb.Pos Maybe.Pos Identity.Pos)). - Definition handleShareNDMaybe {A B : Type} - `{Normalform SShrNDMaybe PShrNDMaybe A B} + Definition handleShareNDMaybe {A : Type} + `{Normalform SShrNDMaybe PShrNDMaybe A} (p : Free SShrNDMaybe PShrNDMaybe A) - : option (list B) := + : option (list nType) := match (run (runMaybe (runChoice (runNDSharing (0,0) (nf p))))) with | None => None - | Some t => Some (@collectVals B t) + | Some t => Some (@collectVals nType t) end. (* Maybe :+: Share :+: Trace :+: Identity handler *) @@ -235,10 +235,10 @@ Section ThreeEffects. (Comb.Pos Share.Pos (Comb.Pos Trace.Pos Identity.Pos)). - Definition handleMaybeShareTrace {A B : Type} - `{Normalform SMaybeShrTrc PMaybeShrTrc A B} + Definition handleMaybeShareTrace {A : Type} + `{Normalform SMaybeShrTrc PMaybeShrTrc A} (p : Free SMaybeShrTrc PMaybeShrTrc A) - : option B * list string := + : option nType * list string := collectMessages (run (runTracing (runTraceSharing (0,0) (runMaybe (nf p))))). @@ -254,10 +254,10 @@ Section ThreeEffects. (Comb.Pos Maybe.Pos (Comb.Pos Trace.Pos Identity.Pos)). - Definition handleNDMaybeTrc {A B : Type} - `{Normalform SNDMaybeTrc PNDMaybeTrc A B} + Definition handleNDMaybeTrc {A : Type} + `{Normalform SNDMaybeTrc PNDMaybeTrc A} (p : Free SNDMaybeTrc PNDMaybeTrc A) - : (option (list B) * list string) := + : (option (list nType) * list string) := let (val,log) := (collectMessages (run (runTracing (runMaybe (runChoice (nf p)))))) in match val with | None => (None, log) @@ -277,10 +277,10 @@ Section ThreeEffects. (Comb.Pos ND.Pos (Comb.Pos (@Error.Pos string) Identity.Pos)). - Definition handleShareNDError {A B : Type} - `{Normalform SShrNDErr PShrNDErr A B} + Definition handleShareNDError {A : Type} + `{Normalform SShrNDErr PShrNDErr A} (p : Free SShrNDErr PShrNDErr A) - : list B + string + : list nType + string := match run (runError (runChoice (runNDSharing (0,0) (nf p)))) with | inl t => inl (collectVals t) | inr e => inr e @@ -298,10 +298,10 @@ Section ThreeEffects. (Comb.Pos Share.Pos (Comb.Pos Trace.Pos Identity.Pos)). - Definition handleErrorShareTrace {A B : Type} - `{Normalform SErrShrTrc PErrShrTrc A B} + Definition handleErrorShareTrace {A : Type} + `{Normalform SErrShrTrc PErrShrTrc A} (p : Free SErrShrTrc PErrShrTrc A) - : (B + string) * list string + : (nType + string) * list string := collectMessages (run (runTracing (runTraceSharing (0,0) (runError (nf p))))). (* ND :+: Error :+: Trace :+: Identity handler *) @@ -316,10 +316,10 @@ Section ThreeEffects. (Comb.Pos (@Error.Pos string) (Comb.Pos Trace.Pos Identity.Pos)). - Definition handleNDErrorTrace {A B : Type} - `{Normalform SNDErrTrc PNDErrTrc A B} + Definition handleNDErrorTrace {A : Type} + `{Normalform SNDErrTrc PNDErrTrc A} (p : Free SNDErrTrc PNDErrTrc A) - : (list B + string) * list string + : (list nType + string) * list string := match collectMessages (run (runTracing (runError (runChoice (nf p))))) with | (inl t, log) => (inl (collectVals t), log) | (inr e, log) => (inr e, log) From 1304908e546579fadd9245a95917eb338b1c5b2b Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 28 Sep 2020 12:26:42 +0200 Subject: [PATCH 101/120] Use generateBind #150 --- .../Converter/TypeDecl/TypeclassInstances.hs | 79 +++++++------------ 1 file changed, 30 insertions(+), 49 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs index 9842d335..2a0e2318 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs @@ -421,41 +421,32 @@ generateTypeclassInstances dataDecls = do -- | Like 'buildNormalformValue', but with an additional parameter to accumulate -- bound variables. buildNormalformValue' - :: [Coq.Qualid] -> [(StrippedType, Coq.Qualid)] -> Converter Coq.Term + :: [Coq.Term] -> [(StrippedType, Coq.Qualid)] -> Converter Coq.Term -- If all components have been normalized, apply the constructor to -- the normalized components. buildNormalformValue' boundVars [] = do - args <- mapM (generatePure . Coq.Qualid) (reverse boundVars) + args <- mapM generatePure (reverse boundVars) generatePure (Coq.app (Coq.Qualid consName) args) -- For each component, apply the appropriate function, bind the -- result and do the remaining computation. buildNormalformValue' boundVars ((t, varName) : consVars) - = case Map.lookup t nameMap of - -- For recursive or indirectly recursive calls, the type map - -- returns the name of the appropriate function to call. - Just funcName -> do - -- Because the functions work on bare values, the component - -- must be bound (to a fresh variable). - x <- freshCoqQualid freshArgPrefix - -- The result of the normalization will also be bound to a fresh variable. - nx <- freshCoqQualid freshNormalformArgPrefix - -- Do the rest of the computation with the added bound result. - rhs <- buildNormalformValue' (nx : boundVars) consVars - -- Construct the actual bindings and return the result. - let c = Coq.fun [nx] [Nothing] rhs - let c' = applyBind (Coq.app (Coq.Qualid funcName) [Coq.Qualid x]) c - return $ applyBind (Coq.Qualid varName) (Coq.fun [x] [Nothing] c') - -- If there is no entry in the type map, we can assume that an instance - -- already exists. Therefore, we apply @nf@ to the component to receive - -- a normalized value. - Nothing -> do - nx <- freshCoqQualid freshNormalformArgPrefix - rhs <- buildNormalformValue' (nx : boundVars) consVars - let c = Coq.fun [nx] [Nothing] rhs - return - $ applyBind (Coq.app (Coq.Qualid Coq.Base.nf) [Coq.Qualid varName]) - c + = let f = (\nx -> buildNormalformValue' (nx : boundVars) consVars) + in case Map.lookup t nameMap of + -- For recursive or indirectly recursive calls, the type map + -- returns the name of the appropriate function to call. + Just funcName -> do + -- Because the functions work on bare values, the component + -- must be bound before applying the normalization. + generateBind (Coq.Qualid varName) freshArgPrefix Nothing + (\x -> generateBind (Coq.app (Coq.Qualid funcName) [x]) + freshNormalformArgPrefix Nothing f) + -- If there is no entry in the type map, we can assume that an instance + -- already exists. Therefore, we apply @nf@ to the component to receive + -- a normalized value. + Nothing -> generateBind + (Coq.app (Coq.Qualid Coq.Base.nf) [Coq.Qualid varName]) + freshNormalformArgPrefix Nothing f ------------------------------------------------------------------------------- -- Functions to Produce @ShareableArgs@ Instances -- @@ -496,26 +487,20 @@ generateTypeclassInstances dataDecls = do buildShareArgsValue nameMap consName = buildShareArgsValue' [] where buildShareArgsValue' - :: [Coq.Qualid] -> [(StrippedType, Coq.Qualid)] -> Converter Coq.Term + :: [Coq.Term] -> [(StrippedType, Coq.Qualid)] -> Converter Coq.Term buildShareArgsValue' vals [] = generatePure - (Coq.app (Coq.Qualid consName) (map Coq.Qualid (reverse vals))) + (Coq.app (Coq.Qualid consName) (reverse vals)) buildShareArgsValue' vals ((t, varName) : consVars) = do - sx <- freshCoqQualid freshSharingArgPrefix - rhs <- buildShareArgsValue' (sx : vals) consVars - case Map.lookup t nameMap of - Just funcName -> do - return - $ applyBind - (Coq.app (Coq.Qualid Coq.Base.cbneed) - (shapeAndPos ++ [Coq.Qualid funcName, Coq.Qualid varName])) - (Coq.fun [sx] [Nothing] rhs) - Nothing -> do - return - $ applyBind - (Coq.app (Coq.Qualid Coq.Base.cbneed) - (shapeAndPos - ++ [Coq.Qualid Coq.Base.shareArgs, Coq.Qualid varName])) - (Coq.fun [sx] [Nothing] rhs) + let lhs = case Map.lookup t nameMap of + Just funcName -> + (Coq.app (Coq.Qualid Coq.Base.cbneed) + (shapeAndPos ++ [Coq.Qualid funcName, Coq.Qualid varName])) + Nothing -> + (Coq.app (Coq.Qualid Coq.Base.cbneed) + (shapeAndPos + ++ [Coq.Qualid Coq.Base.shareArgs, Coq.Qualid varName])) + generateBind lhs freshSharingArgPrefix Nothing + (\val -> buildShareArgsValue' (val : vals) consVars) ------------------------------------------------------------------------------- -- Helper Functions -- @@ -636,10 +621,6 @@ generateTypeclassInstances dataDecls = do typeVarBinder typeVars = Coq.typedBinder Coq.Ungeneralizable Coq.Implicit typeVars Coq.sortType - -- | Shortcut for the application of @>>=@. - applyBind :: Coq.Term -> Coq.Term -> Coq.Term - applyBind mx f = Coq.app (Coq.Qualid Coq.Base.freeBind) [mx, f] - -- | Given an @A@, returns @Free Shape Pos A@. applyFree :: Coq.Term -> Coq.Term applyFree a = genericApply Coq.Base.free [] [] [a] From c619199c6063b5b528beef52f5d640493a4ec592 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 28 Sep 2020 13:11:52 +0200 Subject: [PATCH 102/120] Remove redundant brackets and fix var names in tests #150 --- .../Converter/TypeDecl/TypeclassInstances.hs | 12 +++---- .../Backend/Coq/Converter/TypeDeclTests.hs | 34 +++++++++---------- 2 files changed, 22 insertions(+), 24 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs index 2a0e2318..c35397e2 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/TypeclassInstances.hs @@ -492,13 +492,11 @@ generateTypeclassInstances dataDecls = do (Coq.app (Coq.Qualid consName) (reverse vals)) buildShareArgsValue' vals ((t, varName) : consVars) = do let lhs = case Map.lookup t nameMap of - Just funcName -> - (Coq.app (Coq.Qualid Coq.Base.cbneed) - (shapeAndPos ++ [Coq.Qualid funcName, Coq.Qualid varName])) - Nothing -> - (Coq.app (Coq.Qualid Coq.Base.cbneed) - (shapeAndPos - ++ [Coq.Qualid Coq.Base.shareArgs, Coq.Qualid varName])) + Just funcName -> Coq.app (Coq.Qualid Coq.Base.cbneed) + (shapeAndPos ++ [Coq.Qualid funcName, Coq.Qualid varName]) + Nothing -> Coq.app (Coq.Qualid Coq.Base.cbneed) + (shapeAndPos + ++ [Coq.Qualid Coq.Base.shareArgs, Coq.Qualid varName]) generateBind lhs freshSharingArgPrefix Nothing (\val -> buildShareArgsValue' (val : vals) consVars) diff --git a/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs b/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs index f106d688..7577a6b1 100644 --- a/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs +++ b/src/test/FreeC/Backend/Coq/Converter/TypeDeclTests.hs @@ -122,25 +122,25 @@ testConvertTypeDecl ++ " (Tree Identity.Shape Identity.Pos (@nType Shape Pos a _))" ++ " := let fix nf'ListTree_" ++ " {a0 : Type} `{Normalform Shape Pos a0} " - ++ " (x3 : List Shape Pos (Tree Shape Pos a0)) " + ++ " (x2 : List Shape Pos (Tree Shape Pos a0)) " ++ " : Free Shape Pos (List Identity.Shape Identity.Pos " ++ " (Tree Identity.Shape Identity.Pos" ++ " (@nType Shape Pos a0 _)))" - ++ " := match x3 with " + ++ " := match x2 with " ++ " | nil => pure nil " - ++ " | cons x4 x5 =>" + ++ " | cons x3 x4 =>" + ++ " x3 >>= (fun x5 =>" + ++ " nf'Tree_ x5 >>= (fun nx =>" ++ " x4 >>= (fun x6 =>" - ++ " nf'Tree_ x6 >>= (fun nx1 =>" - ++ " x5 >>= (fun x7 =>" - ++ " nf'ListTree_ x7 >>= (fun nx2 =>" - ++ " pure (cons (pure nx1) (pure nx2))))))" + ++ " nf'ListTree_ x6 >>= (fun nx0 =>" + ++ " pure (cons (pure nx) (pure nx0))))))" ++ " end " ++ " in match x with " ++ " | leaf x0 => nf x0 >>= (fun nx =>" ++ " pure (leaf (pure nx)))" ++ " | branch x1 => x1 >>= (fun x2 => " - ++ " nf'ListTree_ x2 >>= (fun nx0 =>" - ++ " pure (branch (pure nx0))))" + ++ " nf'ListTree_ x2 >>= (fun nx =>" + ++ " pure (branch (pure nx))))" ++ " end. " ++ "Instance NormalformTree_" ++ " {Shape : Type} {Pos : Shape -> Type}" @@ -162,18 +162,18 @@ testConvertTypeDecl ++ " := match x2 with " ++ " | nil => pure nil " ++ " | cons x3 x4 => " - ++ " cbneed Shape Pos shareArgsTree_ x3 >>= (fun sx1 =>" + ++ " cbneed Shape Pos shareArgsTree_ x3 >>= (fun sx =>" ++ " cbneed Shape Pos shareArgsListTree_ x4 >>=" - ++ " (fun sx2 => " - ++ " pure (cons sx1 sx2))) " + ++ " (fun sx0 => " + ++ " pure (cons sx sx0))) " ++ " end " ++ " in match x with " ++ " | leaf x0 => cbneed Shape Pos shareArgs x0 >>= (fun sx =>" ++ " pure (leaf sx)) " ++ " | branch x1 => " ++ " cbneed Shape Pos shareArgsListTree_ x1 >>=" - ++ " (fun sx0 =>" - ++ " pure (branch sx0)) " + ++ " (fun sx =>" + ++ " pure (branch sx)) " ++ " end. " ++ "Instance ShareableArgsTree_" ++ " {Shape : Type} {Pos : Shape -> Type} {a : Type}" @@ -376,7 +376,7 @@ testConvertDataDecls ++ " (@nType Shape Pos a0 _))" ++ " := match x with" ++ " | bar x0 => nf x0 >>= (fun nx => pure (bar (pure nx)))" - ++ " | baz x1 => nf x1 >>= (fun nx0 => pure (baz (pure nx0)))" + ++ " | baz x1 => nf x1 >>= (fun nx => pure (baz (pure nx)))" ++ " end. " ++ "Instance NormalformFoo__" ++ " {Shape : Type} {Pos : Shape -> Type}" @@ -394,8 +394,8 @@ testConvertDataDecls ++ " := match x with" ++ " | bar x0 => cbneed Shape Pos shareArgs x0 >>= (fun sx =>" ++ " pure (bar sx))" - ++ " | baz x1 => cbneed Shape Pos shareArgs x1 >>= (fun sx0 =>" - ++ " pure (baz sx0))" + ++ " | baz x1 => cbneed Shape Pos shareArgs x1 >>= (fun sx =>" + ++ " pure (baz sx))" ++ " end. " ++ "Instance ShareableArgsFoo__" ++ " {Shape : Type} {Pos : Shape -> Type} {a a0 : Type}" From d6da4fece9d6511257c6811da3aa038d43f9003b Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Mon, 28 Sep 2020 13:54:31 +0200 Subject: [PATCH 103/120] Replace aliases of decreasing argument in helper functions #209 --- .../Coq/Converter/FuncDecl/Rec/WithHelpers.hs | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs index cea0ab18..998dfff6 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs @@ -29,6 +29,7 @@ import FreeC.Environment.Renamer import FreeC.IR.Inlining import FreeC.IR.Reference ( freeVarSet ) import FreeC.IR.SrcSpan +import FreeC.IR.Subst import FreeC.IR.Subterm import qualified FreeC.IR.Syntax as IR import FreeC.Monad.Converter @@ -53,6 +54,7 @@ convertRecFuncDeclsWithHelpers' decls = do decArgs <- identifyDecArgs decls (helperDecls, mainDecls) <- mapAndUnzipM (uncurry transformRecFuncDecl) (zip decls decArgs) + -- error (showPretty (map (map fst) helperDecls)) -- Convert helper and main functions. -- The right-hand sides of the main functions are inlined into the helper -- functions. Because inlining can produce fresh identifiers, we need to @@ -132,13 +134,20 @@ transformRecFuncDecl let helperDeclIdent = declIdent { IR.declIdentName = helperName } -- Pass all type arguments to the helper function. let helperTypeArgs = typeArgs + -- Replace aliases of decreasing argument with decreasing argument. + let mkDecArgVar aliasSrcSpan = IR.Var aliasSrcSpan decArg Nothing + aliasSubst = composeSubsts + [singleSubst' alias mkDecArgVar + | alias <- Set.toList (decArgAliasesAt caseExprPos) + ] + caseExpr = selectSubterm' expr caseExprPos + caseExpr' = applySubst aliasSubst caseExpr -- Pass used variables as additional arguments to the helper function -- but don't pass shadowed arguments to helper functions. let boundVarTypeMap = boundVarsWithTypeAt expr caseExprPos boundVars = Map.keysSet boundVarTypeMap `Set.union` Set.fromList argNames - caseExpr = selectSubterm' expr caseExprPos - usedVars = freeVarSet caseExpr + usedVars = freeVarSet caseExpr' helperArgNames = Set.toList (usedVars `Set.intersection` boundVars) -- Determine the types of helper function's arguments and its return type. -- Additionally, the decreasing argument is marked as strict. @@ -155,7 +164,7 @@ transformRecFuncDecl helperArgs = zipWith3 (IR.VarPat NoSrcSpan . fromJust . IR.identFromQName) helperArgNames helperArgTypes helperArgStrict - helperReturnType = IR.exprType caseExpr + helperReturnType = IR.exprType caseExpr' helperType = IR.funcType NoSrcSpan <$> sequence helperArgTypes <*> helperReturnType -- Register the helper function to the environment. @@ -186,7 +195,7 @@ transformRecFuncDecl let helperTypeArgs' = map IR.typeVarDeclToType helperTypeArgs helperAppType = IR.TypeScheme NoSrcSpan [] <$> helperType helperDecl = IR.FuncDecl srcSpan helperDeclIdent helperTypeArgs - helperArgs helperReturnType caseExpr + helperArgs helperReturnType caseExpr' helperApp = IR.app NoSrcSpan (IR.visibleTypeApp NoSrcSpan (IR.Var NoSrcSpan helperName helperAppType) helperTypeArgs') From ea887c6080905d4255478f32fedf0f14dae83dd2 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Mon, 28 Sep 2020 15:37:23 +0200 Subject: [PATCH 104/120] Remove `let` for decreasing argument subterms #209 --- .../Coq/Analysis/DecreasingArguments.hs | 36 +++++++--- .../Coq/Converter/FuncDecl/Rec/WithHelpers.hs | 66 ++++++++++++++++--- .../Converter/FuncDecl/Rec/WithSections.hs | 17 ++--- src/lib/FreeC/IR/Subst.hs | 13 ++++ 4 files changed, 106 insertions(+), 26 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Analysis/DecreasingArguments.hs b/src/lib/FreeC/Backend/Coq/Analysis/DecreasingArguments.hs index 13ffc7e1..592af032 100644 --- a/src/lib/FreeC/Backend/Coq/Analysis/DecreasingArguments.hs +++ b/src/lib/FreeC/Backend/Coq/Analysis/DecreasingArguments.hs @@ -82,9 +82,14 @@ module FreeC.Backend.Coq.Analysis.DecreasingArguments , identifyDecArgs -- * Depth Map , DepthMap + , lookupDepth + , initDepthMap , depthMapAt + , mapChildrenWithDepthMaps + , mapChildrenWithDepthMapsM ) where +import Data.Composition ( (.:.) ) import Data.List ( find ) import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map @@ -163,7 +168,7 @@ checkDecArgs decls knownDecArgIndecies decArgIndecies = all checkDecArg (Just _) _ _ = True checkDecArg _ decArgIndex (IR.FuncDecl _ _ _ args _ rhs) = let decArg = IR.varPatQName (args !! decArgIndex) - in checkExpr (Map.singleton decArg 0) rhs + in checkExpr (initDepthMap decArg) rhs -- | Tests whether there is a variable that is structurally smaller than the -- potential decreasing argument in the position of the decreasing argumnet @@ -201,11 +206,7 @@ checkDecArgs decls knownDecArgIndecies decArgIndecies = all checkExpr' (IR.TypeAppExpr _ expr _ _) args = checkExpr' expr args -- Check all other expressions recursively and extend the 'depthMap' if -- there are variable binders. Arguments are not passed to subterms. - checkExpr' expr _ - = let children = childTerms expr - indicies = [1 .. length children] - depthMaps' = map (($ depthMap) . flip extendDepthMap expr) indicies - in all (uncurry checkExpr) (zip depthMaps' children) + checkExpr' expr _ = and (mapChildrenWithDepthMaps checkExpr depthMap expr) ------------------------------------------------------------------------------- -- Depth Map -- @@ -247,6 +248,10 @@ withDepths = flip (foldr (uncurry withDepth)) withoutArgs :: [IR.VarPat] -> DepthMap -> DepthMap withoutArgs = flip Map.withoutKeys . Set.fromList . map IR.varPatQName +-- | Creates the initial 'DepthMap' for the given decreasing argument. +initDepthMap :: IR.QName -> DepthMap +initDepthMap decArg = Map.singleton decArg 0 + -- | Builds a 'DepthMap' for variables that are bound at the given position -- in the given expression. depthMapAt @@ -254,8 +259,8 @@ depthMapAt -> IR.Expr -- ^ The root expression. -> IR.QName -- ^ The name of the decreasing argument. -> DepthMap -depthMapAt p expr decArg = foldr (uncurry extendDepthMap) - (Map.singleton decArg 0) (mapMaybe selectParent (ancestorPos p)) +depthMapAt p expr decArg = foldr (uncurry extendDepthMap) (initDepthMap decArg) + (mapMaybe selectParent (ancestorPos p)) where -- | Gets the subterm at the parent position of the given position as well -- as the index (starting at @1@) of the position within its parent @@ -263,6 +268,21 @@ depthMapAt p expr decArg = foldr (uncurry extendDepthMap) selectParent :: Pos -> Maybe (Int, IR.Expr) selectParent = fmap (fmap (selectSubterm' expr)) . unConsPos +-- | Applies the given function to the children of the given expression +-- and the extended 'DepthMap' for that child. +mapChildrenWithDepthMaps + :: (DepthMap -> IR.Expr -> a) -> DepthMap -> IR.Expr -> [a] +mapChildrenWithDepthMaps f depthMap expr + = let children = childTerms expr + indicies = [1 .. length children] + depthMaps' = map (($ depthMap) . flip extendDepthMap expr) indicies + in zipWith f depthMaps' children + +-- | Monadic version of 'mapChildrenWithDepthMaps'. +mapChildrenWithDepthMapsM + :: Monad m => (DepthMap -> IR.Expr -> m a) -> DepthMap -> IR.Expr -> m [a] +mapChildrenWithDepthMapsM = sequence .:. mapChildrenWithDepthMaps + -- | Updates the given 'DepthMap' for binders that bind variables in the child -- expression with the given index (starting at @1@) in the given expression. extendDepthMap :: Int -> IR.Expr -> DepthMap -> DepthMap diff --git a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs index 998dfff6..16bbfa15 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs @@ -10,10 +10,11 @@ module FreeC.Backend.Coq.Converter.FuncDecl.Rec.WithHelpers import Control.Monad ( forM, join, mapAndUnzipM ) import Data.List - ( delete, elemIndex ) + ( delete, elemIndex, partition ) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.Strict as Map -import Data.Maybe ( fromJust ) +import Data.Maybe + ( fromJust, isJust ) import Data.Set ( Set ) import qualified Data.Set as Set @@ -62,7 +63,8 @@ convertRecFuncDeclsWithHelpers' decls = do helperDecls' <- forM (concat helperDecls) $ \(helperDecl, decArgIndex) -> localEnv $ do inlinedHelperDecl <- inlineFuncDecls mainDecls helperDecl - convertRecHelperFuncDecl inlinedHelperDecl decArgIndex + eliminatedHelperDecl <- eliminateAliases inlinedHelperDecl decArgIndex + convertRecHelperFuncDecl eliminatedHelperDecl decArgIndex mainDecls' <- convertNonRecFuncDecls mainDecls -- Create common fixpoint sentence for all helper functions. return @@ -135,13 +137,12 @@ transformRecFuncDecl -- Pass all type arguments to the helper function. let helperTypeArgs = typeArgs -- Replace aliases of decreasing argument with decreasing argument. - let mkDecArgVar aliasSrcSpan = IR.Var aliasSrcSpan decArg Nothing - aliasSubst = composeSubsts - [singleSubst' alias mkDecArgVar + let aliasSubst = composeSubsts + [mkVarSubst alias decArg | alias <- Set.toList (decArgAliasesAt caseExprPos) ] - caseExpr = selectSubterm' expr caseExprPos - caseExpr' = applySubst aliasSubst caseExpr + caseExpr = selectSubterm' expr caseExprPos + caseExpr' = applySubst aliasSubst caseExpr -- Pass used variables as additional arguments to the helper function -- but don't pass shadowed arguments to helper functions. let boundVarTypeMap = boundVarsWithTypeAt expr caseExprPos @@ -202,6 +203,55 @@ transformRecFuncDecl (map IR.varPatToExpr helperArgs) return ((helperDecl, decArgIndex'), helperApp) +-- | Replaces aliases of the decreasing argument or variables that are +-- structurally smaller than the decreasing argument in the right-hand +-- side of the given helper function declaration with the corresponding +-- variable. +-- +-- For example, if @xs@ is the decreasing argument expression of the form +-- +-- > let ys = xs in e +-- +-- all occurences of @ys@ is replaced by @xs@ in @e@ and the binding for @ys@ +-- is removed. +-- +-- The purpose of this transformation is to prevent applications of @share@ +-- and @call@ to be generated within helper functions for subterms of the +-- decreasing since they interfere with Coq's termination checker. +eliminateAliases :: IR.FuncDecl -> DecArgIndex -> Converter IR.FuncDecl +eliminateAliases helperDecl decArgIndex = do + let decArg = IR.varPatQName (IR.funcDeclArgs helperDecl !! decArgIndex) + rhs' <- eliminateAliases' (initDepthMap decArg) (IR.funcDeclRhs helperDecl) + return helperDecl { IR.funcDeclRhs = rhs' } + +-- | Replaces aliases in the given expression and keeps track of which +-- variables are structurally smaller or equal with the given 'DepthMap'. +eliminateAliases' :: DepthMap -> IR.Expr -> Converter IR.Expr +eliminateAliases' depthMap expr = case expr of + (IR.Let srcSpan binds inExpr exprType) -> do + let (elimBinds, unElimBinds) = partition shouldEliminate binds + elimNames = map (IR.varPatQName . IR.bindVarPat) + elimBinds + elimExprs = map IR.bindExpr elimBinds + subst = composeSubsts + (zipWith singleSubst elimNames elimExprs) + let binds' = map (applySubst subst) unElimBinds + inExpr' = applySubst subst inExpr + letExpr' = IR.Let srcSpan binds' inExpr' exprType + eliminateInChildren letExpr' + _ -> eliminateInChildren expr + where + -- | Tests whether the given @let@-binding is an alias for a variable that + -- is structurally smaller or equal to the decreasing argument. + shouldEliminate :: IR.Bind -> Bool + shouldEliminate = isJust . flip lookupDepth depthMap . IR.bindExpr + + -- | Applies 'eliminateAliases'' to the children of the given expression. + eliminateInChildren :: IR.Expr -> Converter IR.Expr + eliminateInChildren expr' = do + children' <- mapChildrenWithDepthMapsM eliminateAliases' depthMap expr' + return (fromJust (replaceChildTerms expr' children')) + -- | Converts a recursive helper function to the body of a Coq @Fixpoint@ -- sentence with the decreasing argument at the given index annotated with -- @struct@. diff --git a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithSections.hs b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithSections.hs index 82228889..0e51e901 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithSections.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithSections.hs @@ -136,24 +136,21 @@ renameFuncDecls decls = do -- Create a substitution from old identifiers to fresh identifiers. let names = map IR.funcDeclQName decls names' <- mapM freshHaskellQName names - let nameMap = zip names names' - subst = composeSubsts $ do - (name, name') <- nameMap - return (singleSubst' name (flip IR.untypedVar name')) + let nameMap = Map.fromList (zip names names') + subst = composeSubsts $ zipWith mkVarSubst names names' -- Rename function declarations, apply substituion to right-hand side -- and copy type signature and entry of original function. decls' <- forM decls $ \(IR.FuncDecl srcSpan (IR.DeclIdent srcSpan' name) typeArgs args maybeRetType rhs) -> do - let Just name' = lookup name nameMap + let Just name' = Map.lookup name nameMap -- Generate fresh identifiers for type variables. let typeArgIdents = map IR.typeVarDeclIdent typeArgs typeArgIdents' <- mapM freshHaskellIdent typeArgIdents let typeArgs' = zipWith IR.TypeVarDecl (map IR.typeVarDeclSrcSpan typeArgs) typeArgIdents' typeVarSubst = composeSubsts - (zipWith singleSubst' (map (IR.UnQual . IR.Ident) typeArgIdents) - (map (flip IR.TypeVar) typeArgIdents')) + (zipWith mkTypeVarSubst typeArgIdents typeArgIdents') args' = applySubst typeVarSubst args maybeRetType' = applySubst typeVarSubst maybeRetType -- Set environment entry for renamed function. @@ -176,7 +173,7 @@ renameFuncDecls decls = do -- Rename function declaration. return (IR.FuncDecl srcSpan (IR.DeclIdent srcSpan' name') typeArgs' args' maybeRetType' rhs') - return (decls', Map.fromList nameMap) + return (decls', nameMap) -- | Replaces the function names in the given 'ConstArg' using the given map. renameConstArg :: Map IR.QName IR.QName -> ConstArg -> ConstArg @@ -280,8 +277,8 @@ removeConstArgsFromFuncDecl constArgs args' = [arg | arg <- args, IR.varPatIdent arg `notElem` removedArgs] subst = composeSubsts - [singleSubst' (IR.UnQual (IR.Ident removedArg)) - (flip IR.untypedVar (IR.UnQual (IR.Ident freshArg))) + [mkVarSubst (IR.UnQual (IR.Ident removedArg)) + (IR.UnQual (IR.Ident freshArg)) | (removedArg, freshArg) <- zip removedArgs freshArgs ] rhs' <- removeConstArgsFromExpr constArgs (applySubst subst rhs) diff --git a/src/lib/FreeC/IR/Subst.hs b/src/lib/FreeC/IR/Subst.hs index 6f1c5e21..4400fcec 100644 --- a/src/lib/FreeC/IR/Subst.hs +++ b/src/lib/FreeC/IR/Subst.hs @@ -11,6 +11,8 @@ module FreeC.IR.Subst , identitySubst , singleSubst , singleSubst' + , mkVarSubst + , mkTypeVarSubst -- * Composition , composeSubst , composeSubsts @@ -75,6 +77,17 @@ singleSubst = flip (flip singleSubst' . const) singleSubst' :: IR.QName -> (SrcSpan -> a) -> Subst a singleSubst' = Subst .: Map.singleton +-- | Creates a substitution that renames variables with the given name and +-- preserves source span information of the renamed variable. +mkVarSubst :: IR.QName -> IR.QName -> Subst IR.Expr +mkVarSubst v1 v2 = singleSubst' v1 (flip IR.untypedVar v2) + +-- | Creates a substitution that renames type variables with the given name +-- and preserves source span information of the renamed type variable. +mkTypeVarSubst :: String -> String -> Subst IR.Type +mkTypeVarSubst v1 v2 = singleSubst' (IR.UnQual (IR.Ident v1)) + (flip IR.TypeVar v2) + ------------------------------------------------------------------------------- -- Composition -- ------------------------------------------------------------------------------- From 98e0e8641f1b05b8aebfe2b8ba3ba7b147c8e956 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Mon, 28 Sep 2020 15:53:01 +0200 Subject: [PATCH 105/120] Fix application of helper functions #209 --- .../Coq/Analysis/DecreasingArguments.hs | 7 --- .../Coq/Converter/FuncDecl/Rec/WithHelpers.hs | 44 ++++++++++--------- .../FuncDecl/Rec/WithHelpersTests.hs | 33 ++++++++++++++ 3 files changed, 56 insertions(+), 28 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Analysis/DecreasingArguments.hs b/src/lib/FreeC/Backend/Coq/Analysis/DecreasingArguments.hs index 592af032..2aeb42c1 100644 --- a/src/lib/FreeC/Backend/Coq/Analysis/DecreasingArguments.hs +++ b/src/lib/FreeC/Backend/Coq/Analysis/DecreasingArguments.hs @@ -86,10 +86,8 @@ module FreeC.Backend.Coq.Analysis.DecreasingArguments , initDepthMap , depthMapAt , mapChildrenWithDepthMaps - , mapChildrenWithDepthMapsM ) where -import Data.Composition ( (.:.) ) import Data.List ( find ) import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map @@ -278,11 +276,6 @@ mapChildrenWithDepthMaps f depthMap expr depthMaps' = map (($ depthMap) . flip extendDepthMap expr) indicies in zipWith f depthMaps' children --- | Monadic version of 'mapChildrenWithDepthMaps'. -mapChildrenWithDepthMapsM - :: Monad m => (DepthMap -> IR.Expr -> m a) -> DepthMap -> IR.Expr -> m [a] -mapChildrenWithDepthMapsM = sequence .:. mapChildrenWithDepthMaps - -- | Updates the given 'DepthMap' for binders that bind variables in the child -- expression with the given index (starting at @1@) in the given expression. extendDepthMap :: Int -> IR.Expr -> DepthMap -> DepthMap diff --git a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs index 16bbfa15..01d38aa6 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs @@ -63,7 +63,7 @@ convertRecFuncDeclsWithHelpers' decls = do helperDecls' <- forM (concat helperDecls) $ \(helperDecl, decArgIndex) -> localEnv $ do inlinedHelperDecl <- inlineFuncDecls mainDecls helperDecl - eliminatedHelperDecl <- eliminateAliases inlinedHelperDecl decArgIndex + let eliminatedHelperDecl = eliminateAliases inlinedHelperDecl decArgIndex convertRecHelperFuncDecl eliminatedHelperDecl decArgIndex mainDecls' <- convertNonRecFuncDecls mainDecls -- Create common fixpoint sentence for all helper functions. @@ -201,7 +201,12 @@ transformRecFuncDecl (IR.visibleTypeApp NoSrcSpan (IR.Var NoSrcSpan helperName helperAppType) helperTypeArgs') (map IR.varPatToExpr helperArgs) - return ((helperDecl, decArgIndex'), helperApp) + -- The decreasing argument must be instantiated with the scrutinee of the + -- @case@-expression the helper function has been created for (prior to + -- renaming of aliases). + let scrutinee = IR.caseExprScrutinee caseExpr + helperApp' = applySubst (singleSubst decArg scrutinee) helperApp + return ((helperDecl, decArgIndex'), helperApp') -- | Replaces aliases of the decreasing argument or variables that are -- structurally smaller than the decreasing argument in the right-hand @@ -218,27 +223,24 @@ transformRecFuncDecl -- The purpose of this transformation is to prevent applications of @share@ -- and @call@ to be generated within helper functions for subterms of the -- decreasing since they interfere with Coq's termination checker. -eliminateAliases :: IR.FuncDecl -> DecArgIndex -> Converter IR.FuncDecl -eliminateAliases helperDecl decArgIndex = do +eliminateAliases :: IR.FuncDecl -> DecArgIndex -> IR.FuncDecl +eliminateAliases helperDecl decArgIndex = let decArg = IR.varPatQName (IR.funcDeclArgs helperDecl !! decArgIndex) - rhs' <- eliminateAliases' (initDepthMap decArg) (IR.funcDeclRhs helperDecl) - return helperDecl { IR.funcDeclRhs = rhs' } + in helperDecl { IR.funcDeclRhs = eliminateAliases' (initDepthMap decArg) (IR.funcDeclRhs helperDecl) } -- | Replaces aliases in the given expression and keeps track of which -- variables are structurally smaller or equal with the given 'DepthMap'. -eliminateAliases' :: DepthMap -> IR.Expr -> Converter IR.Expr +eliminateAliases' :: DepthMap -> IR.Expr -> IR.Expr eliminateAliases' depthMap expr = case expr of - (IR.Let srcSpan binds inExpr exprType) -> do - let (elimBinds, unElimBinds) = partition shouldEliminate binds - elimNames = map (IR.varPatQName . IR.bindVarPat) - elimBinds - elimExprs = map IR.bindExpr elimBinds - subst = composeSubsts - (zipWith singleSubst elimNames elimExprs) - let binds' = map (applySubst subst) unElimBinds - inExpr' = applySubst subst inExpr + (IR.Let srcSpan binds inExpr exprType) -> + let (eliminatedBinds, perservedBinds) = partition shouldEliminate binds + names = map (IR.varPatQName . IR.bindVarPat) eliminatedBinds + exprs = map IR.bindExpr eliminatedBinds + subst = composeSubsts (zipWith singleSubst names exprs) + binds' = map (applySubst subst) perservedBinds + inExpr' = applySubst subst inExpr letExpr' = IR.Let srcSpan binds' inExpr' exprType - eliminateInChildren letExpr' + in eliminateInChildren letExpr' _ -> eliminateInChildren expr where -- | Tests whether the given @let@-binding is an alias for a variable that @@ -247,10 +249,10 @@ eliminateAliases' depthMap expr = case expr of shouldEliminate = isJust . flip lookupDepth depthMap . IR.bindExpr -- | Applies 'eliminateAliases'' to the children of the given expression. - eliminateInChildren :: IR.Expr -> Converter IR.Expr - eliminateInChildren expr' = do - children' <- mapChildrenWithDepthMapsM eliminateAliases' depthMap expr' - return (fromJust (replaceChildTerms expr' children')) + eliminateInChildren :: IR.Expr -> IR.Expr + eliminateInChildren expr' + = let children' = mapChildrenWithDepthMaps eliminateAliases' depthMap expr' + in fromJust (replaceChildTerms expr' children') -- | Converts a recursive helper function to the body of a Coq @Fixpoint@ -- sentence with the decreasing argument at the given index annotated with diff --git a/src/test/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpersTests.hs b/src/test/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpersTests.hs index 524542ca..7877d1a3 100644 --- a/src/test/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpersTests.hs +++ b/src/test/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpersTests.hs @@ -638,3 +638,36 @@ testConvertRecFuncDeclWithHelpers = context "with helper functions" $ do ] convertRecFuncDeclsWithHelpers input in shouldThrow (avoidLaziness res) (errorCall "Maybe.fromJust: Nothing") + it "translates recursive functions with `let`-bindings correctly" + $ shouldSucceedWith + $ do + "Integer" <- defineTestTypeCon "Integer" 0 [] + "succ" <- defineTestFunc "succ" 1 "Integer -> Integer" + "List" <- defineTestTypeCon "List" 1 ["Nil", "Cons"] + ("nil", "Nil") <- defineTestCon "Nil" 0 "forall a. List a" + ("cons", "Cons") + <- defineTestCon "Cons" 2 "forall a. a -> List a -> List a" + "length" <- defineTestFunc "length" 1 "forall a. List a -> Integer" + shouldConvertWithHelpersTo + [ "length @a (xs :: List a) :: Integer" + ++ " = let { ys = xs } in case ys of {" + ++ " Nil -> 0;" + ++ " Cons x xs' -> let { ys' = xs' } in succ (length @a ys')" + ++ " }" + ] + $ "(* Helper functions for length *) " + ++ "Fixpoint length0 (Shape : Type) (Pos : Shape -> Type) {a : Type}" + ++ " (xs : List Shape Pos a)" + ++ " {struct xs}" + ++ " := match xs with" + ++ " | nil => pure 0%Z" + ++ " | cons x xs' => succ Shape Pos" + ++ " (xs' >>= (fun (xs'0 : List Shape Pos a) =>" + ++ " @length0 Shape Pos a xs'0))" + ++ " end. " + ++ "Definition length (Shape : Type) (Pos : Shape -> Type) {a : Type}" + ++ " (xs : Free Shape Pos (List Shape Pos a))" + ++ " : Free Shape Pos (Integer Shape Pos)" + ++ " := share Shape Pos S xs >>= (fun ys =>" + ++ " ys >>= (fun (ys0 : List Shape Pos a) =>" + ++ " @length0 Shape Pos a ys0))." From b785754501ba9724d176e40d367c511cb8f37506 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Mon, 28 Sep 2020 16:13:45 +0200 Subject: [PATCH 106/120] Add test case for `let`-expressions in helper functions #209 --- .../FuncDecl/Rec/WithHelpersTests.hs | 38 ++++++++++++++++++- 1 file changed, 37 insertions(+), 1 deletion(-) diff --git a/src/test/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpersTests.hs b/src/test/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpersTests.hs index fc962519..7df9b654 100644 --- a/src/test/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpersTests.hs +++ b/src/test/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpersTests.hs @@ -638,7 +638,7 @@ testConvertRecFuncDeclWithHelpers = context "with helper functions" $ do ] convertRecFuncDeclsWithHelpers input in shouldThrow (avoidLaziness res) (errorCall "Maybe.fromJust: Nothing") - it "translates recursive functions with `let`-bindings correctly" + it "eliminates `let`-bindings for decreasing argument in helper functions" $ shouldSucceedWith $ do "Integer" <- defineTestTypeCon "Integer" 0 [] @@ -671,3 +671,39 @@ testConvertRecFuncDeclWithHelpers = context "with helper functions" $ do ++ " := call Shape Pos S xs >>= (fun ys =>" ++ " ys >>= (fun (ys0 : List Shape Pos a) =>" ++ " @length0 Shape Pos a ys0))." + it "does not eliminate other `let`-bindings in helper functions" + $ shouldSucceedWith + $ do + "Integer" <- defineTestTypeCon "Integer" 0 [] + "succ" <- defineTestFunc "succ" 1 "Integer -> Integer" + "List" <- defineTestTypeCon "List" 1 ["Nil", "Cons"] + ("nil", "Nil") <- defineTestCon "Nil" 0 "forall a. List a" + ("cons", "Cons") + <- defineTestCon "Cons" 2 "forall a. a -> List a -> List a" + "length" <- defineTestFunc "length" 1 "forall a. List a -> Integer" + shouldConvertWithHelpersTo + [ "length @a (xs :: List a) :: Integer" + ++ " = let { zero = 0 } in case xs of {" + ++ " Nil -> zero;" + ++ " Cons x xs' -> let { y = x ; z = zero }" + ++ " in succ (length @a xs')" + ++ " }" + ] + $ "(* Helper functions for length *) " + ++ "Fixpoint length0 (Shape : Type) (Pos : Shape -> Type) {a : Type}" + ++ " (xs : List Shape Pos a)" + ++ " (zero : Integer Shape Pos)" + ++ " {struct xs}" + ++ " := match xs with" + ++ " | nil => zero" + ++ " | cons x xs' => succ Shape Pos" + ++ " call Shape Pos S (pure 0%Z) >>= (fun zero0 =>" + ++ " (xs' >>= (fun (xs'0 : List Shape Pos a) =>" + ++ " @length0 Shape Pos a xs'0 zero0))" + ++ " end. " + ++ "Definition length (Shape : Type) (Pos : Shape -> Type) {a : Type}" + ++ " (xs : Free Shape Pos (List Shape Pos a))" + ++ " : Free Shape Pos (Integer Shape Pos)" + ++ " := call Shape Pos S zero >>= (fun z =>" + ++ " xs >>= (fun (xs0 : List Shape Pos a) =>" + ++ " @length0 Shape Pos a xs0 zero))." From edf1bbed564316fde89d7131ff4b54e229f89f0a Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Mon, 28 Sep 2020 16:14:40 +0200 Subject: [PATCH 107/120] Format code #213 --- .../Coq/Converter/FuncDecl/Rec/WithHelpers.hs | 10 +-- .../FuncDecl/Rec/WithHelpersTests.hs | 66 +++++++++---------- 2 files changed, 39 insertions(+), 37 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs index 01d38aa6..0183d176 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs @@ -204,7 +204,7 @@ transformRecFuncDecl -- The decreasing argument must be instantiated with the scrutinee of the -- @case@-expression the helper function has been created for (prior to -- renaming of aliases). - let scrutinee = IR.caseExprScrutinee caseExpr + let scrutinee = IR.caseExprScrutinee caseExpr helperApp' = applySubst (singleSubst decArg scrutinee) helperApp return ((helperDecl, decArgIndex'), helperApp') @@ -224,9 +224,11 @@ transformRecFuncDecl -- and @call@ to be generated within helper functions for subterms of the -- decreasing since they interfere with Coq's termination checker. eliminateAliases :: IR.FuncDecl -> DecArgIndex -> IR.FuncDecl -eliminateAliases helperDecl decArgIndex = - let decArg = IR.varPatQName (IR.funcDeclArgs helperDecl !! decArgIndex) - in helperDecl { IR.funcDeclRhs = eliminateAliases' (initDepthMap decArg) (IR.funcDeclRhs helperDecl) } +eliminateAliases helperDecl decArgIndex + = let decArg = IR.varPatQName (IR.funcDeclArgs helperDecl !! decArgIndex) + in helperDecl { IR.funcDeclRhs = eliminateAliases' (initDepthMap decArg) + (IR.funcDeclRhs helperDecl) + } -- | Replaces aliases in the given expression and keeps track of which -- variables are structurally smaller or equal with the given 'DepthMap'. diff --git a/src/test/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpersTests.hs b/src/test/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpersTests.hs index 7df9b654..d1a3b759 100644 --- a/src/test/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpersTests.hs +++ b/src/test/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpersTests.hs @@ -674,36 +674,36 @@ testConvertRecFuncDeclWithHelpers = context "with helper functions" $ do it "does not eliminate other `let`-bindings in helper functions" $ shouldSucceedWith $ do - "Integer" <- defineTestTypeCon "Integer" 0 [] - "succ" <- defineTestFunc "succ" 1 "Integer -> Integer" - "List" <- defineTestTypeCon "List" 1 ["Nil", "Cons"] - ("nil", "Nil") <- defineTestCon "Nil" 0 "forall a. List a" - ("cons", "Cons") - <- defineTestCon "Cons" 2 "forall a. a -> List a -> List a" - "length" <- defineTestFunc "length" 1 "forall a. List a -> Integer" - shouldConvertWithHelpersTo - [ "length @a (xs :: List a) :: Integer" - ++ " = let { zero = 0 } in case xs of {" - ++ " Nil -> zero;" - ++ " Cons x xs' -> let { y = x ; z = zero }" - ++ " in succ (length @a xs')" - ++ " }" - ] - $ "(* Helper functions for length *) " - ++ "Fixpoint length0 (Shape : Type) (Pos : Shape -> Type) {a : Type}" - ++ " (xs : List Shape Pos a)" - ++ " (zero : Integer Shape Pos)" - ++ " {struct xs}" - ++ " := match xs with" - ++ " | nil => zero" - ++ " | cons x xs' => succ Shape Pos" - ++ " call Shape Pos S (pure 0%Z) >>= (fun zero0 =>" - ++ " (xs' >>= (fun (xs'0 : List Shape Pos a) =>" - ++ " @length0 Shape Pos a xs'0 zero0))" - ++ " end. " - ++ "Definition length (Shape : Type) (Pos : Shape -> Type) {a : Type}" - ++ " (xs : Free Shape Pos (List Shape Pos a))" - ++ " : Free Shape Pos (Integer Shape Pos)" - ++ " := call Shape Pos S zero >>= (fun z =>" - ++ " xs >>= (fun (xs0 : List Shape Pos a) =>" - ++ " @length0 Shape Pos a xs0 zero))." + "Integer" <- defineTestTypeCon "Integer" 0 [] + "succ" <- defineTestFunc "succ" 1 "Integer -> Integer" + "List" <- defineTestTypeCon "List" 1 ["Nil", "Cons"] + ("nil", "Nil") <- defineTestCon "Nil" 0 "forall a. List a" + ("cons", "Cons") + <- defineTestCon "Cons" 2 "forall a. a -> List a -> List a" + "length" <- defineTestFunc "length" 1 "forall a. List a -> Integer" + shouldConvertWithHelpersTo + [ "length @a (xs :: List a) :: Integer" + ++ " = let { zero = 0 } in case xs of {" + ++ " Nil -> zero;" + ++ " Cons x xs' -> let { y = x ; z = zero }" + ++ " in succ (length @a xs')" + ++ " }" + ] + $ "(* Helper functions for length *) " + ++ "Fixpoint length0 (Shape : Type) (Pos : Shape -> Type) {a : Type}" + ++ " (xs : List Shape Pos a)" + ++ " (zero : Integer Shape Pos)" + ++ " {struct xs}" + ++ " := match xs with" + ++ " | nil => zero" + ++ " | cons x xs' => succ Shape Pos" + ++ " call Shape Pos S (pure 0%Z) >>= (fun zero0 =>" + ++ " (xs' >>= (fun (xs'0 : List Shape Pos a) =>" + ++ " @length0 Shape Pos a xs'0 zero0))" + ++ " end. " + ++ "Definition length (Shape : Type) (Pos : Shape -> Type) {a : Type}" + ++ " (xs : Free Shape Pos (List Shape Pos a))" + ++ " : Free Shape Pos (Integer Shape Pos)" + ++ " := call Shape Pos S zero >>= (fun z =>" + ++ " xs >>= (fun (xs0 : List Shape Pos a) =>" + ++ " @length0 Shape Pos a xs0 zero))." From a055a66c0d3ae4a8925c5f5c5f60573dcdcafaa6 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Tue, 8 Sep 2020 17:55:53 +0200 Subject: [PATCH 108/120] Fix bound variables of `let`-expression #76 Cherry picked from 7cf8a24b96a7a5286aeefe5e8f20132708840859. --- src/lib/FreeC/IR/Subterm.hs | 68 ++++++++++++++++++++++++--------- src/lib/FreeC/IR/Syntax/Expr.hs | 2 +- 2 files changed, 51 insertions(+), 19 deletions(-) diff --git a/src/lib/FreeC/IR/Subterm.hs b/src/lib/FreeC/IR/Subterm.hs index 3ced812c..8ff8f6e1 100644 --- a/src/lib/FreeC/IR/Subterm.hs +++ b/src/lib/FreeC/IR/Subterm.hs @@ -32,6 +32,8 @@ module FreeC.IR.Subterm , mapSubterms , mapSubtermsM -- * Bound Variables + , boundVarsOf + , boundVarsWithTypeOf , boundVarsAt , boundVarsWithTypeAt ) where @@ -329,6 +331,51 @@ mapSubtermsM f term = do ------------------------------------------------------------------------------- -- Bound Variables -- ------------------------------------------------------------------------------- +-- | Gets the names of variables that are bound by the given expression in its +-- subterm at the given index. +-- +-- For example, a @case@-expression +-- +-- > case e { … ; Cᵢ x₁ … xₙ -> eᵢ ; … } +-- +-- with subterms @[e, e₁, …, eₙ]@ binds the variables @x₁ … xₙ@ in it's +-- @i+1@th subterm @eᵢ@ but no variables are bound in @e@ (i.e., if @i = 0@). +-- +-- Returns an empty map if the expression does not have such a subterm. +boundVarsOf :: IR.Expr -> Int -> Set IR.QName +boundVarsOf = Map.keysSet .: boundVarsWithTypeOf + +-- | Like 'boundVarsOf' but also returns the annotated type of the +-- variable pattern. +-- +-- Returns an empty map if the expression does not have such a subterm. +boundVarsWithTypeOf :: IR.Expr -> Int -> Map IR.QName (Maybe IR.Type) +boundVarsWithTypeOf expr i = case expr of + -- A lambda abstraction binds the arguments in the right-hand side. + IR.Lambda _ args _ _ -> fromVarPats args + -- A @let@-expression binds local variables in the @in@-expression + -- as well as all binders. + IR.Let _ binds _ _ -> fromVarPats (map IR.bindVarPat binds) + -- Only alternatives of @case@-expressions bind variables. + -- The @case@-expression itself does not bind any variables. + IR.Case _ _ alts _ | i >= 1 && i <= length alts -> fromVarPats + (IR.altVarPats (alts !! (i - 1))) + | otherwise -> Map.empty + -- All other expressions don't bind variables. + IR.Con _ _ _ -> Map.empty + IR.Var _ _ _ -> Map.empty + IR.App _ _ _ _ -> Map.empty + IR.TypeAppExpr _ _ _ _ -> Map.empty + IR.If _ _ _ _ _ -> Map.empty + IR.Undefined _ _ -> Map.empty + IR.ErrorExpr _ _ _ -> Map.empty + IR.IntLiteral _ _ _ -> Map.empty + where + -- | Converts a list of variable patterns to a from of variable names bound + -- by these patterns to the types they have been annotated with. + fromVarPats :: [IR.VarPat] -> Map IR.QName (Maybe IR.Type) + fromVarPats = Map.fromList . map (IR.varPatQName &&& IR.varPatType) + -- | Gets the names of variables that are bound by lambda abstractions or -- variable patterns in @case@-expressions at the given position of an -- expression. @@ -351,21 +398,6 @@ boundVarsWithTypeAt = fromMaybe Map.empty .: boundVarsWithTypeAt' boundVarsWithTypeAt' _ (Pos []) = return Map.empty boundVarsWithTypeAt' expr (Pos (p : ps)) = do child <- selectSubterm expr (Pos [p]) - bvars <- boundVarsWithTypeAt' child (Pos ps) - case expr of - (IR.Case _ _ alts _) - | p > 1 -> do - let altVars = altBoundVarsWithType (alts !! (p - 2)) - return (bvars `Map.union` altVars) - (IR.Lambda _ args _ _) -> return (bvars `Map.union` fromVarPats args) - _ -> return bvars - - -- | Gets the names of variables bound by the variable patterns of the given - -- @case@-expression alternative. - altBoundVarsWithType :: IR.Alt -> Map IR.QName (Maybe IR.Type) - altBoundVarsWithType (IR.Alt _ _ varPats _) = fromVarPats varPats - - -- | Converts a list of variable patterns to a set of variable names bound - -- by these patterns. - fromVarPats :: [IR.VarPat] -> Map IR.QName (Maybe IR.Type) - fromVarPats = Map.fromList . map (IR.varPatQName &&& IR.varPatType) + boundInChild <- boundVarsWithTypeAt' child (Pos ps) + let boundLocally = boundVarsWithTypeOf expr (p - 1) + return (boundInChild `Map.union` boundLocally) diff --git a/src/lib/FreeC/IR/Syntax/Expr.hs b/src/lib/FreeC/IR/Syntax/Expr.hs index 57b63023..2d3a9e1a 100644 --- a/src/lib/FreeC/IR/Syntax/Expr.hs +++ b/src/lib/FreeC/IR/Syntax/Expr.hs @@ -65,7 +65,7 @@ data Expr -- | A lambda abstraction. | Lambda { exprSrcSpan :: SrcSpan , lambdaExprArgs :: [VarPat] - , lambdaEprRhs :: Expr + , lambdaExprRhs :: Expr , exprTypeScheme :: Maybe TypeScheme } -- | A let expression. From 2c2d0f5df51478471732e60f84026d05aef6de39 Mon Sep 17 00:00:00 2001 From: Justin Andresen Date: Mon, 28 Sep 2020 16:38:04 +0200 Subject: [PATCH 109/120] Fix test case #209 --- .../FuncDecl/Rec/WithHelpersTests.hs | 21 +++++++++++-------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/src/test/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpersTests.hs b/src/test/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpersTests.hs index d1a3b759..0565b262 100644 --- a/src/test/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpersTests.hs +++ b/src/test/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpersTests.hs @@ -683,7 +683,7 @@ testConvertRecFuncDeclWithHelpers = context "with helper functions" $ do "length" <- defineTestFunc "length" 1 "forall a. List a -> Integer" shouldConvertWithHelpersTo [ "length @a (xs :: List a) :: Integer" - ++ " = let { zero = 0 } in case xs of {" + ++ " = let { (zero :: Integer) = 0 } in case xs of {" ++ " Nil -> zero;" ++ " Cons x xs' -> let { y = x ; z = zero }" ++ " in succ (length @a xs')" @@ -692,18 +692,21 @@ testConvertRecFuncDeclWithHelpers = context "with helper functions" $ do $ "(* Helper functions for length *) " ++ "Fixpoint length0 (Shape : Type) (Pos : Shape -> Type) {a : Type}" ++ " (xs : List Shape Pos a)" - ++ " (zero : Integer Shape Pos)" + ++ " (zero : Free Shape Pos (Integer Shape Pos))" ++ " {struct xs}" ++ " := match xs with" ++ " | nil => zero" - ++ " | cons x xs' => succ Shape Pos" - ++ " call Shape Pos S (pure 0%Z) >>= (fun zero0 =>" - ++ " (xs' >>= (fun (xs'0 : List Shape Pos a) =>" - ++ " @length0 Shape Pos a xs'0 zero0))" + ++ " | cons x xs' => call Shape Pos S zero >>= (fun z =>" + ++ " succ Shape Pos" + ++ " (@call Shape Pos S (Integer Shape Pos) (pure 0%Z) >>=" + ++ " (fun (zero0 : Free Shape Pos (Integer Shape Pos)) =>" + ++ " xs' >>= (fun (xs'0 : List Shape Pos a) =>" + ++ " @length0 Shape Pos a xs'0 zero0))))" ++ " end. " ++ "Definition length (Shape : Type) (Pos : Shape -> Type) {a : Type}" ++ " (xs : Free Shape Pos (List Shape Pos a))" ++ " : Free Shape Pos (Integer Shape Pos)" - ++ " := call Shape Pos S zero >>= (fun z =>" - ++ " xs >>= (fun (xs0 : List Shape Pos a) =>" - ++ " @length0 Shape Pos a xs0 zero))." + ++ " := @call Shape Pos S (Integer Shape Pos) (pure 0%Z) >>=" + ++ " (fun (zero : Free Shape Pos (Integer Shape Pos)) =>" + ++ " xs >>= (fun (xs0 : List Shape Pos a) =>" + ++ " @length0 Shape Pos a xs0 zero))." From fcb72f0620dd296a9bbcc63934a35199ce113f1a Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 28 Sep 2020 18:43:33 +0200 Subject: [PATCH 110/120] Encapsulate sharing when necessary #211 --- src/lib/FreeC/Pass/SharingAnalysisPass.hs | 171 ++++++++++++++-------- 1 file changed, 106 insertions(+), 65 deletions(-) diff --git a/src/lib/FreeC/Pass/SharingAnalysisPass.hs b/src/lib/FreeC/Pass/SharingAnalysisPass.hs index aa82bd3b..4ee1f168 100644 --- a/src/lib/FreeC/Pass/SharingAnalysisPass.hs +++ b/src/lib/FreeC/Pass/SharingAnalysisPass.hs @@ -68,11 +68,13 @@ module FreeC.Pass.SharingAnalysisPass , analyseLocalSharing ) where -import Control.Monad ( (>=>), mapAndUnzipM ) +import Control.Monad ( (>=>), mapAndUnzipM, foldM ) import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map import Data.Set as Set ( fromList ) +import FreeC.Environment ( lookupEntry ) +import FreeC.Environment.Entry import FreeC.Environment.Fresh ( freshHaskellName ) import FreeC.IR.SrcSpan import FreeC.IR.Subst @@ -94,8 +96,9 @@ sharingAnaylsisPass ast = do -- @let@-expressions and applies the transformation on the right-hand side. analyseSharingDecl :: IR.FuncDecl -> Converter IR.FuncDecl analyseSharingDecl funcDecl = do + let declArgs = IR.funcDeclArgs funcDecl rhs' - <- (analyseLocalSharing >=> analyseSharingExpr (IR.funcDeclArgs funcDecl)) + <- ((analyseLocalSharing declArgs ) >=> analyseSharingExpr declArgs) (IR.funcDeclRhs funcDecl) return funcDecl { IR.funcDeclRhs = rhs' } @@ -105,55 +108,77 @@ analyseSharingDecl funcDecl = do -- -- If a variable is shared, a @let@-expression that makes the sharing -- explicit is introduced. -analyseLocalSharing :: IR.Expr -> Converter IR.Expr -analyseLocalSharing (IR.Case srcSpan expr alts typeScheme) = do - expr' <- analyseLocalSharing expr +analyseLocalSharing :: [IR.VarPat] -> IR.Expr -> Converter IR.Expr +analyseLocalSharing varPats (IR.Case srcSpan expr alts typeScheme) = do + expr' <- analyseLocalSharing varPats expr alts' <- mapM analyseSharingAlt alts return (IR.Case srcSpan expr' alts' typeScheme) where analyseSharingAlt :: IR.Alt -> Converter IR.Alt analyseSharingAlt (IR.Alt altSrcSpan altConPat altVarPats altRhs) = do - let varNames = map IR.varPatQName altVarPats - varList = (map fst - . filter ((> 1) . snd) - . Map.toList - . countVarNamesOnly varNames) altRhs - altRhs' <- buildLet altRhs varList + let varPats' = varPats ++ altVarPats + altRhs' <- analyseLocalSharing varPats' altRhs >>= analyseSharingExpr varPats' return (IR.Alt altSrcSpan altConPat altVarPats altRhs') -analyseLocalSharing (IR.Lambda srcSpan exprArgs rhs typeScheme) = do - let varNames = map IR.varPatQName exprArgs - varList = (map fst - . filter ((> 1) . snd) - . Map.toList - . countVarNamesOnly varNames) rhs - rhs' <- buildLet rhs varList +analyseLocalSharing varPats (IR.Lambda srcSpan exprArgs rhs typeScheme) = do + let varPats' = varPats ++ exprArgs + rhs' <- (analyseLocalSharing varPats' >=> analyseSharingExpr varPats') rhs return (IR.Lambda srcSpan exprArgs rhs' typeScheme) -analyseLocalSharing expr@IR.Con {} = return expr -analyseLocalSharing expr@IR.Undefined {} = return expr -analyseLocalSharing expr@IR.ErrorExpr {} = return expr -analyseLocalSharing expr@IR.Var {} = return expr -analyseLocalSharing expr@IR.IntLiteral {} = return expr -analyseLocalSharing (IR.Let srcSpan binds rhs typeScheme) = do +analyseLocalSharing _ expr@IR.Con {} = return expr +analyseLocalSharing _ expr@IR.Undefined {} = return expr +analyseLocalSharing _ expr@IR.ErrorExpr {} = return expr +analyseLocalSharing _ expr@IR.Var {} = return expr +analyseLocalSharing _ expr@IR.IntLiteral {} = return expr +analyseLocalSharing varPats (IR.Let srcSpan binds rhs typeScheme) = do binds' <- mapM analyseSharingBind binds - rhs' <- analyseLocalSharing rhs + rhs' <- analyseLocalSharing varPats rhs return (IR.Let srcSpan binds' rhs' typeScheme) where analyseSharingBind :: IR.Bind -> Converter IR.Bind analyseSharingBind (IR.Bind bindSrcSpan bindVarPat bindRhs) = do - bindRhs' <- analyseLocalSharing bindRhs + bindRhs' <- analyseLocalSharing varPats bindRhs return (IR.Bind bindSrcSpan bindVarPat bindRhs') -analyseLocalSharing (IR.If srcSpan e1 e2 e3 typeScheme) = do - e1' <- analyseLocalSharing e1 - e2' <- analyseLocalSharing e2 - e3' <- analyseLocalSharing e3 +analyseLocalSharing varPats (IR.If srcSpan e1 e2 e3 typeScheme) = do + e1' <- analyseLocalSharing varPats e1 + e2' <- analyseLocalSharing varPats e2 + e3' <- analyseLocalSharing varPats e3 return (IR.If srcSpan e1' e2' e3' typeScheme) -analyseLocalSharing (IR.TypeAppExpr srcSpan lhs rhs typeScheme) = do - lhs' <- analyseLocalSharing lhs +analyseLocalSharing varPats (IR.TypeAppExpr srcSpan lhs rhs typeScheme) = do + lhs' <- analyseLocalSharing varPats lhs return (IR.TypeAppExpr srcSpan lhs' rhs typeScheme) -analyseLocalSharing (IR.App srcSpan lhs rhs typeScheme) = do - lhs' <- analyseLocalSharing lhs - rhs' <- analyseLocalSharing rhs - return (IR.App srcSpan lhs' rhs' typeScheme) +analyseLocalSharing varPats expr@(IR.App srcSpan lhs rhs typeScheme) = do + encSharing <- shouldEncapsulateSharing lhs + if encSharing + then encapsulateSharing varPats expr + else do + lhs' <- analyseLocalSharing varPats lhs + rhs' <- analyseLocalSharing varPats rhs + return (IR.App srcSpan lhs' rhs' typeScheme) + +-- | Returns the function or constructor name of an application. +getLeftmostSymbol :: IR.Expr -> IR.VarName +getLeftmostSymbol (IR.Var _ varName _) = varName +getLeftmostSymbol (IR.App _ lhs _ _) = getLeftmostSymbol lhs +getLeftmostSymbol _ = error "getLeftmostSymbol: unexpected expression" + +-- | Whether an expression is an application of a function that encapsulates +-- effects. +shouldEncapsulateSharing :: IR.Expr -> Converter Bool +shouldEncapsulateSharing expr = do + let funcName = getLeftmostSymbol expr + Just entry <- inEnv $ lookupEntry IR.ValueScope funcName + if isFuncEntry entry then + return $ entryEncapsulatesEffects entry + else return False + +-- | Builds let expressions for variables with more than one occurrence +-- for each argument of a function that encapsulates effects. +encapsulateSharing :: [IR.VarPat] -> IR.Expr -> Converter IR.Expr +encapsulateSharing _ var@(IR.Var _ _ _) = return var +encapsulateSharing varPats (IR.App srcSpan lhs rhs typeScheme) = do + rhs' <- analyseLocalSharing varPats rhs >>= analyseSharingExpr varPats + lhs' <- encapsulateSharing varPats lhs + return (IR.App srcSpan lhs' rhs' typeScheme) +encapsulateSharing _ _ = error "encapsulateSharing: unexpected expression" -- | Checks if an expression contains variables that occur -- multiple times on the same right-hand side. @@ -163,10 +188,8 @@ analyseLocalSharing (IR.App srcSpan lhs rhs typeScheme) = do analyseSharingExpr :: [IR.VarPat] -> IR.Expr -> Converter IR.Expr analyseSharingExpr varPats expr = do let varPatNames = map (IR.UnQual . IR.Ident . IR.varPatIdent) varPats - varList = (map fst - . filter ((> 1) . snd) - . Map.toList - . countVarNamesOnly varPatNames) expr + varMap <- countVarNamesOnly varPatNames expr + let varList = (map fst . filter ((> 1) . snd) . Map.toList) varMap buildLet expr varList -- | Builds a @let@-expression from the given expression and variable names. @@ -206,40 +229,58 @@ buildBinds srcSpan = mapAndUnzipM buildBind -- Shadowed variables and variables from the list are not counted. -- Variables introduced on the left side of a @case@-alternative and @let@ -- expressions are not counted as well. -countVarNamesOnly :: [IR.VarName] -> IR.Expr -> Map IR.VarName Integer -countVarNamesOnly varNames expr - = countVarNames expr `Map.restrictKeys` Set.fromList varNames +countVarNamesOnly :: [IR.VarName] -> IR.Expr -> Converter (Map IR.VarName Integer) +countVarNamesOnly varNames expr = do + varMap <- countVarNames expr + return $ varMap `Map.restrictKeys` Set.fromList varNames -- | Counts all variable names on right-hand sides of expression. -- Shadowed variables and variables from the list are not counted. -- Variables introduced on the left side of a @case@-alternative and @let@ -- expressions are not counted as well. -countVarNames :: IR.Expr -> Map IR.VarName Integer -countVarNames (IR.Var _ varName _) = Map.singleton varName 1 -countVarNames (IR.App _ lhs rhs _) - = countVarNames lhs `mergeMap` countVarNames rhs +countVarNames :: IR.Expr -> Converter (Map IR.VarName Integer) +countVarNames (IR.Var _ varName _) = return $ Map.singleton varName 1 +countVarNames (IR.App _ lhs rhs _) = do + encSharing <- shouldEncapsulateSharing lhs + -- Do not count variables that occur in applications of functions that + -- encapsulate effects. + if encSharing + then return Map.empty + else do + lhsVars <- countVarNames lhs + rhsVars <- countVarNames rhs + return $ lhsVars `mergeMap` rhsVars countVarNames (IR.TypeAppExpr _ lhs _ _) = countVarNames lhs -countVarNames (IR.If _ e1 e2 e3 _) = countVarNames e1 - `mergeMap` Map.unionWith max (countVarNames e2) (countVarNames e3) -countVarNames IR.Con {} = Map.empty -countVarNames IR.Undefined {} = Map.empty -countVarNames IR.ErrorExpr {} = Map.empty -countVarNames IR.IntLiteral {} = Map.empty +countVarNames (IR.If _ e1 e2 e3 _) = do + map1 <- countVarNames e1 + map2 <- countVarNames e2 + map3 <- countVarNames e3 + return $ map1 `mergeMap` Map.unionWith max map2 map3 +countVarNames IR.Con {} = return $ Map.empty +countVarNames IR.Undefined {} = return $ Map.empty +countVarNames IR.ErrorExpr {} = return $ Map.empty +countVarNames IR.IntLiteral {} = return $ Map.empty countVarNames (IR.Case _ e alts _) - = let altVars = concatMap (map IR.varPatQName . IR.altVarPats) alts - completeMap = countVarNames e - `mergeMap` foldr (mergeMap . countVarNames . IR.altRhs) Map.empty alts - `mergeMap` foldr (Map.unionWith max . countVarNames . IR.altRhs) - Map.empty alts - in completeMap `Map.withoutKeys` Set.fromList altVars -countVarNames (IR.Lambda _ args rhs _) = countVarNames rhs - `Map.withoutKeys` Set.fromList (map IR.varPatQName args) + = do + let altVars = concatMap (map IR.varPatQName . IR.altVarPats) alts + map1 <- countVarNames e + map2 <- foldM (\m alt -> mergeMap m <$> countVarNames (IR.altRhs alt)) Map.empty alts + map3 <- foldM (\m alt -> Map.unionWith max m <$> countVarNames (IR.altRhs alt)) Map.empty alts + let completeMap = map1 `mergeMap` map2 `mergeMap` map3 + return $ completeMap `Map.withoutKeys` Set.fromList altVars +countVarNames (IR.Lambda _ args rhs _) = do + rhsVars <- countVarNames rhs + return $ rhsVars `Map.withoutKeys` Set.fromList (map IR.varPatQName args) countVarNames (IR.Let _ binds e _) - = let bindVars = map (IR.varPatQName . IR.bindVarPat) binds - completeMap = countVarNames e + = do + let bindVars = map (IR.varPatQName . IR.bindVarPat) binds + map1 <- countVarNames e + map2 <- foldM (\m bind -> mergeMap m <$> countVarNames (IR.bindExpr bind)) Map.empty binds + let completeMap = mergeMap map1 map2 + {- completeMap = countVarNames e `mergeMap` foldr (mergeMap . countVarNames . IR.bindExpr) Map.empty - binds - in completeMap `Map.withoutKeys` Set.fromList bindVars + binds-} + return $ completeMap `Map.withoutKeys` Set.fromList bindVars mergeMap :: Map IR.VarName Integer -> Map IR.VarName Integer -> Map IR.VarName Integer From 53c13533e7155e905a887488f646f28b44fa8501 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 28 Sep 2020 18:48:30 +0200 Subject: [PATCH 111/120] Use varPatQName and format code #211 --- .../Coq/Converter/FuncDecl/Rec/WithHelpers.hs | 22 ++-- src/lib/FreeC/Environment.hs | 1 - src/lib/FreeC/Environment/Entry.hs | 22 ++-- .../Environment/ModuleInterface/Decoder.hs | 22 ++-- src/lib/FreeC/Pass/DefineDeclPass.hs | 23 ++-- src/lib/FreeC/Pass/SharingAnalysisPass.hs | 113 +++++++++--------- src/lib/FreeC/Pipeline.hs | 4 +- src/test/FreeC/Test/Environment.hs | 22 ++-- 8 files changed, 114 insertions(+), 115 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs index 1a9cf96b..49b3d790 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/FuncDecl/Rec/WithHelpers.hs @@ -169,18 +169,18 @@ transformRecFuncDecl effects <- inEnv $ lookupEffects name _entry <- renameAndAddEntry $ FuncEntry - { entrySrcSpan = NoSrcSpan - , entryArity = length helperArgTypes - , entryTypeArgs = map IR.typeVarDeclIdent helperTypeArgs - , entryArgTypes = map fromJust helperArgTypes - , entryStrictArgs = map IR.varPatIsStrict helperArgs - , entryReturnType = fromJust helperReturnType - , entryNeedsFreeArgs = freeArgsNeeded + { entrySrcSpan = NoSrcSpan + , entryArity = length helperArgTypes + , entryTypeArgs = map IR.typeVarDeclIdent helperTypeArgs + , entryArgTypes = map fromJust helperArgTypes + , entryStrictArgs = map IR.varPatIsStrict helperArgs + , entryReturnType = fromJust helperReturnType + , entryNeedsFreeArgs = freeArgsNeeded , entryEncapsulatesEffects = encEffects - , entryEffects = effects - , entryName = helperName - , entryIdent = undefined -- filled by renamer - , entryAgdaIdent = undefined -- filled by renamer + , entryEffects = effects + , entryName = helperName + , entryIdent = undefined -- filled by renamer + , entryAgdaIdent = undefined -- filled by renamer } -- Determine the index of the decreasing argument. let decArgIndex' = fromJust $ elemIndex decArg helperArgNames diff --git a/src/lib/FreeC/Environment.hs b/src/lib/FreeC/Environment.hs index 8d4255d5..8d7d7873 100644 --- a/src/lib/FreeC/Environment.hs +++ b/src/lib/FreeC/Environment.hs @@ -159,7 +159,6 @@ addEffectsToEntry name effects env = case lookupEntry IR.ValueScope name env of ------------------------------------------------------------------------------- -- Looking up Entries from the Environment -- ------------------------------------------------------------------------------- - -- | Tests whether the function with the given name encapsulates effects. -- -- Returns @False@ if there is no such function. diff --git a/src/lib/FreeC/Environment/Entry.hs b/src/lib/FreeC/Environment/Entry.hs index cb404c5d..bdac464d 100644 --- a/src/lib/FreeC/Environment/Entry.hs +++ b/src/lib/FreeC/Environment/Entry.hs @@ -85,33 +85,33 @@ data EnvEntry } -- | Entry for a function declaration. | FuncEntry - { entrySrcSpan :: SrcSpan + { entrySrcSpan :: SrcSpan -- ^ The source code location where the function was declared. - , entryArity :: Int + , entryArity :: Int -- ^ The number of arguments expected by the function. - , entryTypeArgs :: [IR.TypeVarIdent] + , entryTypeArgs :: [IR.TypeVarIdent] -- ^ The names of the type arguments. - , entryArgTypes :: [IR.Type] + , entryArgTypes :: [IR.Type] -- ^ The types of the function arguments. -- Contains exactly 'entryArity' elements. - , entryStrictArgs :: [Bool] + , entryStrictArgs :: [Bool] -- ^ Whether each argument is strict. -- Contains exactly 'entryArity' elements. - , entryReturnType :: IR.Type + , entryReturnType :: IR.Type -- ^ The return type of the function (if known). - , entryNeedsFreeArgs :: Bool + , entryNeedsFreeArgs :: Bool -- ^ Whether the arguments of the @Free@ monad need to be -- passed to the function. , entryEncapsulatesEffects :: Bool -- ^ Whether the function should encapsulate effects. - , entryEffects :: [Effect] + , entryEffects :: [Effect] -- ^ The effects of the function, i.e. which type classes are needed -- during the translation. - , entryIdent :: Coq.Qualid + , entryIdent :: Coq.Qualid -- ^ The name of the function in Coq. - , entryAgdaIdent :: Agda.QName + , entryAgdaIdent :: Agda.QName -- ^ The name of the function in Agda. - , entryName :: IR.QName + , entryName :: IR.QName -- ^ The name of the function in the module it has been defined in. } -- | Entry for a variable. diff --git a/src/lib/FreeC/Environment/ModuleInterface/Decoder.hs b/src/lib/FreeC/Environment/ModuleInterface/Decoder.hs index 7562c520..8c745ded 100644 --- a/src/lib/FreeC/Environment/ModuleInterface/Decoder.hs +++ b/src/lib/FreeC/Environment/ModuleInterface/Decoder.hs @@ -279,18 +279,18 @@ instance Aeson.FromJSON ModuleInterface where let (argTypes, returnType) = IR.splitFuncType haskellType arity typeArgs = freeTypeVars haskellType return FuncEntry - { entrySrcSpan = NoSrcSpan - , entryArity = arity - , entryTypeArgs = typeArgs - , entryArgTypes = argTypes - , entryStrictArgs = replicate arity False - , entryReturnType = returnType - , entryNeedsFreeArgs = freeArgsNeeded + { entrySrcSpan = NoSrcSpan + , entryArity = arity + , entryTypeArgs = typeArgs + , entryArgTypes = argTypes + , entryStrictArgs = replicate arity False + , entryReturnType = returnType + , entryNeedsFreeArgs = freeArgsNeeded , entryEncapsulatesEffects = effectsEncapsulated - , entryEffects = effects - , entryIdent = coqName - , entryAgdaIdent = agdaName - , entryName = haskellName + , entryEffects = effects + , entryIdent = coqName + , entryAgdaIdent = agdaName + , entryName = haskellName } -- | Loads a module interface file from a @.toml@ or @.json@ file. diff --git a/src/lib/FreeC/Pass/DefineDeclPass.hs b/src/lib/FreeC/Pass/DefineDeclPass.hs index 5eb0fcfc..2800ce00 100644 --- a/src/lib/FreeC/Pass/DefineDeclPass.hs +++ b/src/lib/FreeC/Pass/DefineDeclPass.hs @@ -110,19 +110,20 @@ defineTypeDecl (IR.DataDecl srcSpan declIdent typeArgs conDecls) = do defineFuncDecl :: IR.FuncDecl -> Converter () defineFuncDecl funcDecl = do _ <- renameAndAddEntry FuncEntry - { entrySrcSpan = IR.funcDeclSrcSpan funcDecl - , entryArity = length (IR.funcDeclArgs funcDecl) - , entryTypeArgs = map IR.typeVarDeclIdent + { entrySrcSpan = IR.funcDeclSrcSpan funcDecl + , entryArity = length (IR.funcDeclArgs funcDecl) + , entryTypeArgs = map IR.typeVarDeclIdent (IR.funcDeclTypeArgs funcDecl) - , entryArgTypes = map (fromJust . IR.varPatType) + , entryArgTypes = map (fromJust . IR.varPatType) (IR.funcDeclArgs funcDecl) - , entryStrictArgs = map IR.varPatIsStrict (IR.funcDeclArgs funcDecl) - , entryReturnType = fromJust (IR.funcDeclReturnType funcDecl) - , entryNeedsFreeArgs = True + , entryStrictArgs = map IR.varPatIsStrict + (IR.funcDeclArgs funcDecl) + , entryReturnType = fromJust (IR.funcDeclReturnType funcDecl) + , entryNeedsFreeArgs = True , entryEncapsulatesEffects = False - , entryEffects = [] -- may be updated by effect analysis pass - , entryName = IR.funcDeclQName funcDecl - , entryIdent = undefined -- filled by renamer - , entryAgdaIdent = undefined -- filled by renamer + , entryEffects = [] -- may be updated by effect analysis pass + , entryName = IR.funcDeclQName funcDecl + , entryIdent = undefined -- filled by renamer + , entryAgdaIdent = undefined -- filled by renamer } return () diff --git a/src/lib/FreeC/Pass/SharingAnalysisPass.hs b/src/lib/FreeC/Pass/SharingAnalysisPass.hs index 4ee1f168..1091fdf1 100644 --- a/src/lib/FreeC/Pass/SharingAnalysisPass.hs +++ b/src/lib/FreeC/Pass/SharingAnalysisPass.hs @@ -68,12 +68,12 @@ module FreeC.Pass.SharingAnalysisPass , analyseLocalSharing ) where -import Control.Monad ( (>=>), mapAndUnzipM, foldM ) +import Control.Monad ( (>=>), foldM, mapAndUnzipM ) import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map import Data.Set as Set ( fromList ) -import FreeC.Environment ( lookupEntry ) +import FreeC.Environment ( lookupEntry ) import FreeC.Environment.Entry import FreeC.Environment.Fresh ( freshHaskellName ) import FreeC.IR.SrcSpan @@ -97,8 +97,7 @@ sharingAnaylsisPass ast = do analyseSharingDecl :: IR.FuncDecl -> Converter IR.FuncDecl analyseSharingDecl funcDecl = do let declArgs = IR.funcDeclArgs funcDecl - rhs' - <- ((analyseLocalSharing declArgs ) >=> analyseSharingExpr declArgs) + rhs' <- ((analyseLocalSharing declArgs) >=> analyseSharingExpr declArgs) (IR.funcDeclRhs funcDecl) return funcDecl { IR.funcDeclRhs = rhs' } @@ -117,7 +116,8 @@ analyseLocalSharing varPats (IR.Case srcSpan expr alts typeScheme) = do analyseSharingAlt :: IR.Alt -> Converter IR.Alt analyseSharingAlt (IR.Alt altSrcSpan altConPat altVarPats altRhs) = do let varPats' = varPats ++ altVarPats - altRhs' <- analyseLocalSharing varPats' altRhs >>= analyseSharingExpr varPats' + altRhs' + <- analyseLocalSharing varPats' altRhs >>= analyseSharingExpr varPats' return (IR.Alt altSrcSpan altConPat altVarPats altRhs') analyseLocalSharing varPats (IR.Lambda srcSpan exprArgs rhs typeScheme) = do let varPats' = varPats ++ exprArgs @@ -147,37 +147,36 @@ analyseLocalSharing varPats (IR.TypeAppExpr srcSpan lhs rhs typeScheme) = do return (IR.TypeAppExpr srcSpan lhs' rhs typeScheme) analyseLocalSharing varPats expr@(IR.App srcSpan lhs rhs typeScheme) = do encSharing <- shouldEncapsulateSharing lhs - if encSharing - then encapsulateSharing varPats expr - else do - lhs' <- analyseLocalSharing varPats lhs - rhs' <- analyseLocalSharing varPats rhs - return (IR.App srcSpan lhs' rhs' typeScheme) + if encSharing then encapsulateSharing varPats expr else do + lhs' <- analyseLocalSharing varPats lhs + rhs' <- analyseLocalSharing varPats rhs + return (IR.App srcSpan lhs' rhs' typeScheme) -- | Returns the function or constructor name of an application. getLeftmostSymbol :: IR.Expr -> IR.VarName getLeftmostSymbol (IR.Var _ varName _) = varName -getLeftmostSymbol (IR.App _ lhs _ _) = getLeftmostSymbol lhs -getLeftmostSymbol _ = error "getLeftmostSymbol: unexpected expression" +getLeftmostSymbol (IR.App _ lhs _ _) = getLeftmostSymbol lhs +getLeftmostSymbol _ + = error "getLeftmostSymbol: unexpected expression" -- | Whether an expression is an application of a function that encapsulates -- effects. shouldEncapsulateSharing :: IR.Expr -> Converter Bool shouldEncapsulateSharing expr = do - let funcName = getLeftmostSymbol expr - Just entry <- inEnv $ lookupEntry IR.ValueScope funcName - if isFuncEntry entry then - return $ entryEncapsulatesEffects entry - else return False + let funcName = getLeftmostSymbol expr + Just entry <- inEnv $ lookupEntry IR.ValueScope funcName + if isFuncEntry entry + then return $ entryEncapsulatesEffects entry + else return False -- | Builds let expressions for variables with more than one occurrence -- for each argument of a function that encapsulates effects. encapsulateSharing :: [IR.VarPat] -> IR.Expr -> Converter IR.Expr encapsulateSharing _ var@(IR.Var _ _ _) = return var encapsulateSharing varPats (IR.App srcSpan lhs rhs typeScheme) = do - rhs' <- analyseLocalSharing varPats rhs >>= analyseSharingExpr varPats - lhs' <- encapsulateSharing varPats lhs - return (IR.App srcSpan lhs' rhs' typeScheme) + rhs' <- analyseLocalSharing varPats rhs >>= analyseSharingExpr varPats + lhs' <- encapsulateSharing varPats lhs + return (IR.App srcSpan lhs' rhs' typeScheme) encapsulateSharing _ _ = error "encapsulateSharing: unexpected expression" -- | Checks if an expression contains variables that occur @@ -187,7 +186,7 @@ encapsulateSharing _ _ = error "encapsulateSharing: unexpected expression" -- introduced variable. analyseSharingExpr :: [IR.VarPat] -> IR.Expr -> Converter IR.Expr analyseSharingExpr varPats expr = do - let varPatNames = map (IR.UnQual . IR.Ident . IR.varPatIdent) varPats + let varPatNames = map IR.varPatQName varPats varMap <- countVarNamesOnly varPatNames expr let varList = (map fst . filter ((> 1) . snd) . Map.toList) varMap buildLet expr varList @@ -229,10 +228,11 @@ buildBinds srcSpan = mapAndUnzipM buildBind -- Shadowed variables and variables from the list are not counted. -- Variables introduced on the left side of a @case@-alternative and @let@ -- expressions are not counted as well. -countVarNamesOnly :: [IR.VarName] -> IR.Expr -> Converter (Map IR.VarName Integer) +countVarNamesOnly + :: [IR.VarName] -> IR.Expr -> Converter (Map IR.VarName Integer) countVarNamesOnly varNames expr = do - varMap <- countVarNames expr - return $ varMap `Map.restrictKeys` Set.fromList varNames + varMap <- countVarNames expr + return $ varMap `Map.restrictKeys` Set.fromList varNames -- | Counts all variable names on right-hand sides of expression. -- Shadowed variables and variables from the list are not counted. @@ -240,47 +240,46 @@ countVarNamesOnly varNames expr = do -- expressions are not counted as well. countVarNames :: IR.Expr -> Converter (Map IR.VarName Integer) countVarNames (IR.Var _ varName _) = return $ Map.singleton varName 1 -countVarNames (IR.App _ lhs rhs _) = do - encSharing <- shouldEncapsulateSharing lhs - -- Do not count variables that occur in applications of functions that - -- encapsulate effects. - if encSharing - then return Map.empty - else do - lhsVars <- countVarNames lhs - rhsVars <- countVarNames rhs - return $ lhsVars `mergeMap` rhsVars +countVarNames (IR.App _ lhs rhs _) = do + encSharing <- shouldEncapsulateSharing lhs + -- Do not count variables that occur in applications of functions that + -- encapsulate effects. + if encSharing then return Map.empty else do + lhsVars <- countVarNames lhs + rhsVars <- countVarNames rhs + return $ lhsVars `mergeMap` rhsVars countVarNames (IR.TypeAppExpr _ lhs _ _) = countVarNames lhs countVarNames (IR.If _ e1 e2 e3 _) = do - map1 <- countVarNames e1 - map2 <- countVarNames e2 - map3 <- countVarNames e3 - return $ map1 `mergeMap` Map.unionWith max map2 map3 + map1 <- countVarNames e1 + map2 <- countVarNames e2 + map3 <- countVarNames e3 + return $ map1 `mergeMap` Map.unionWith max map2 map3 countVarNames IR.Con {} = return $ Map.empty countVarNames IR.Undefined {} = return $ Map.empty countVarNames IR.ErrorExpr {} = return $ Map.empty countVarNames IR.IntLiteral {} = return $ Map.empty -countVarNames (IR.Case _ e alts _) - = do - let altVars = concatMap (map IR.varPatQName . IR.altVarPats) alts - map1 <- countVarNames e - map2 <- foldM (\m alt -> mergeMap m <$> countVarNames (IR.altRhs alt)) Map.empty alts - map3 <- foldM (\m alt -> Map.unionWith max m <$> countVarNames (IR.altRhs alt)) Map.empty alts - let completeMap = map1 `mergeMap` map2 `mergeMap` map3 - return $ completeMap `Map.withoutKeys` Set.fromList altVars +countVarNames (IR.Case _ e alts _) = do + let altVars = concatMap (map IR.varPatQName . IR.altVarPats) alts + map1 <- countVarNames e + map2 <- foldM (\m alt -> mergeMap m <$> countVarNames (IR.altRhs alt)) + Map.empty alts + map3 <- foldM (\m alt -> Map.unionWith max m + <$> countVarNames (IR.altRhs alt)) Map.empty alts + let completeMap = map1 `mergeMap` map2 `mergeMap` map3 + return $ completeMap `Map.withoutKeys` Set.fromList altVars countVarNames (IR.Lambda _ args rhs _) = do - rhsVars <- countVarNames rhs - return $ rhsVars `Map.withoutKeys` Set.fromList (map IR.varPatQName args) -countVarNames (IR.Let _ binds e _) - = do - let bindVars = map (IR.varPatQName . IR.bindVarPat) binds - map1 <- countVarNames e - map2 <- foldM (\m bind -> mergeMap m <$> countVarNames (IR.bindExpr bind)) Map.empty binds - let completeMap = mergeMap map1 map2 - {- completeMap = countVarNames e + rhsVars <- countVarNames rhs + return $ rhsVars `Map.withoutKeys` Set.fromList (map IR.varPatQName args) +countVarNames (IR.Let _ binds e _) = do + let bindVars = map (IR.varPatQName . IR.bindVarPat) binds + map1 <- countVarNames e + map2 <- foldM (\m bind -> mergeMap m <$> countVarNames (IR.bindExpr bind)) + Map.empty binds + let completeMap = mergeMap map1 map2 + {- completeMap = countVarNames e `mergeMap` foldr (mergeMap . countVarNames . IR.bindExpr) Map.empty binds-} - return $ completeMap `Map.withoutKeys` Set.fromList bindVars + return $ completeMap `Map.withoutKeys` Set.fromList bindVars mergeMap :: Map IR.VarName Integer -> Map IR.VarName Integer -> Map IR.VarName Integer diff --git a/src/lib/FreeC/Pipeline.hs b/src/lib/FreeC/Pipeline.hs index 3bd9ca91..130690e7 100644 --- a/src/lib/FreeC/Pipeline.hs +++ b/src/lib/FreeC/Pipeline.hs @@ -17,7 +17,7 @@ import FreeC.Pass.DependencyAnalysisPass import FreeC.Pass.EffectAnalysisPass import FreeC.Pass.EtaConversionPass import FreeC.Pass.ExportPass ---import FreeC.Pass.FlattenExprPass TODO uncomment me +import FreeC.Pass.FlattenExprPass --TODO uncomment me import FreeC.Pass.ImplicitPreludePass import FreeC.Pass.ImportPass import FreeC.Pass.KindCheckPass @@ -41,7 +41,7 @@ pipeline = implicitPreludePass >=> typeSignaturePass >=> pragmaPass >=> sharingAnaylsisPass - -- >=> flattenExprPass TODO uncomment me + >=> flattenExprPass --TODO uncomment me >=> dependencyAnalysisPass (typeInferencePass >=> defineFuncDeclsPass >=> effectAnalysisPass) >=> completePatternPass diff --git a/src/test/FreeC/Test/Environment.hs b/src/test/FreeC/Test/Environment.hs index 5ce0caaf..ca98febc 100644 --- a/src/test/FreeC/Test/Environment.hs +++ b/src/test/FreeC/Test/Environment.hs @@ -169,18 +169,18 @@ defineTestFunc' partial areStrict nameStr arity typeStr = do IR.TypeScheme _ typeArgs typeExpr <- parseExplicitTestTypeScheme typeStr let (argTypes, returnType) = IR.splitFuncType typeExpr arity renameAndAddTestEntry FuncEntry - { entrySrcSpan = NoSrcSpan - , entryArity = arity - , entryTypeArgs = map IR.typeVarDeclIdent typeArgs - , entryArgTypes = argTypes - , entryStrictArgs = areStrict - , entryReturnType = returnType - , entryNeedsFreeArgs = True + { entrySrcSpan = NoSrcSpan + , entryArity = arity + , entryTypeArgs = map IR.typeVarDeclIdent typeArgs + , entryArgTypes = argTypes + , entryStrictArgs = areStrict + , entryReturnType = returnType + , entryNeedsFreeArgs = True , entryEncapsulatesEffects = False - , entryEffects = [Partiality | partial] - , entryName = name - , entryIdent = undefined -- filled by renamer - , entryAgdaIdent = undefined -- filled by renamer + , entryEffects = [Partiality | partial] + , entryName = name + , entryIdent = undefined -- filled by renamer + , entryAgdaIdent = undefined -- filled by renamer } -- | Like 'defineTestFunc' but also marks the given function as partial. From 83fc6e5bc2b0e716e1b9d459c0a8cd5113424b65 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 28 Sep 2020 19:49:11 +0200 Subject: [PATCH 112/120] WIP --- src/lib/FreeC/IR/Syntax/Expr.hs | 8 ++++++++ src/lib/FreeC/Pass/FlattenExprPass.hs | 16 +++++++++++++++- src/lib/FreeC/Pass/SharingAnalysisPass.hs | 17 ++--------------- 3 files changed, 25 insertions(+), 16 deletions(-) diff --git a/src/lib/FreeC/IR/Syntax/Expr.hs b/src/lib/FreeC/IR/Syntax/Expr.hs index 2d3a9e1a..53dbc84f 100644 --- a/src/lib/FreeC/IR/Syntax/Expr.hs +++ b/src/lib/FreeC/IR/Syntax/Expr.hs @@ -176,6 +176,14 @@ conApp srcSpan = app srcSpan . untypedCon srcSpan visibleTypeApp :: SrcSpan -> Expr -> [Type] -> Expr visibleTypeApp = foldl . untypedTypeAppExpr +-- | Returns the function or constructor name of an application. +getFuncName :: Expr -> VarName +getFuncName (Var _ varName _) = varName +getFuncName (App _ lhs _ _) = getFuncName lhs +getFuncName _ + = error "getFuncName: unexpected expression" + + -- | Pretty instance for expressions. -- -- If the expression contains type annotations, the output quickly becomes diff --git a/src/lib/FreeC/Pass/FlattenExprPass.hs b/src/lib/FreeC/Pass/FlattenExprPass.hs index 71f2b6d5..7af59877 100644 --- a/src/lib/FreeC/Pass/FlattenExprPass.hs +++ b/src/lib/FreeC/Pass/FlattenExprPass.hs @@ -48,6 +48,7 @@ module FreeC.Pass.FlattenExprPass import Control.Monad ( (>=>), mapAndUnzipM ) import Data.Maybe ( catMaybes ) +import FreeC.Environment ( encapsulatesEffects ) import FreeC.Environment.Fresh ( freshArgPrefix, freshHaskellIdent ) import qualified FreeC.IR.Syntax as IR import FreeC.Monad.Converter @@ -74,7 +75,14 @@ flatExpr (IR.Con srcSpan conName typeScheme) typeArgs args = buildLet (IR.Con srcSpan conName typeScheme) typeArgs args flatExpr (IR.Var srcSpan varName typeScheme) typeArgs args = buildLet (IR.Var srcSpan varName typeScheme) typeArgs args -flatExpr (IR.App _ lhs rhs _) typeArgs args = flatExpr lhs typeArgs (rhs : args) +flatExpr (IR.App srcSpan lhs rhs typeScheme) typeArgs args = do + encEffects <- shouldEncapsulateEffects lhs + if encEffects + then do + lhs' <- flatExpr lhs typeArgs args + rhs' <- flatExpr rhs typeArgs args + return $ IR.App srcSpan lhs' rhs' typeScheme + else flatExpr lhs typeArgs (rhs : args) flatExpr (IR.TypeAppExpr _ expr typeArg _) typeArgs args = flatExpr expr (typeArg : typeArgs) args flatExpr (IR.If srcSpan e1 e2 e3 typeScheme) typeArgs args = do @@ -131,3 +139,9 @@ buildLet e' typeArgs args = do varName = (IR.UnQual $ IR.Ident varIdent) var = IR.Var srcSpan varName (IR.exprTypeScheme expr) return (Just bind, var) + +-- | Whether an expression is an application of a function that encapsulates +-- effects. +shouldEncapsulateEffects :: IR.Expr -> Converter Bool +shouldEncapsulateEffects expr = inEnv $ encapsulatesEffects (IR.getFuncName expr) + diff --git a/src/lib/FreeC/Pass/SharingAnalysisPass.hs b/src/lib/FreeC/Pass/SharingAnalysisPass.hs index 1091fdf1..8ecb43b0 100644 --- a/src/lib/FreeC/Pass/SharingAnalysisPass.hs +++ b/src/lib/FreeC/Pass/SharingAnalysisPass.hs @@ -73,8 +73,7 @@ import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map import Data.Set as Set ( fromList ) -import FreeC.Environment ( lookupEntry ) -import FreeC.Environment.Entry +import FreeC.Environment ( encapsulatesEffects ) import FreeC.Environment.Fresh ( freshHaskellName ) import FreeC.IR.SrcSpan import FreeC.IR.Subst @@ -152,22 +151,10 @@ analyseLocalSharing varPats expr@(IR.App srcSpan lhs rhs typeScheme) = do rhs' <- analyseLocalSharing varPats rhs return (IR.App srcSpan lhs' rhs' typeScheme) --- | Returns the function or constructor name of an application. -getLeftmostSymbol :: IR.Expr -> IR.VarName -getLeftmostSymbol (IR.Var _ varName _) = varName -getLeftmostSymbol (IR.App _ lhs _ _) = getLeftmostSymbol lhs -getLeftmostSymbol _ - = error "getLeftmostSymbol: unexpected expression" - -- | Whether an expression is an application of a function that encapsulates -- effects. shouldEncapsulateSharing :: IR.Expr -> Converter Bool -shouldEncapsulateSharing expr = do - let funcName = getLeftmostSymbol expr - Just entry <- inEnv $ lookupEntry IR.ValueScope funcName - if isFuncEntry entry - then return $ entryEncapsulatesEffects entry - else return False +shouldEncapsulateSharing expr = inEnv $ encapsulatesEffects (IR.getFuncName expr) -- | Builds let expressions for variables with more than one occurrence -- for each argument of a function that encapsulates effects. From 80d9175f368e45de5cce5c2ff006d4bf5f31f556 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 28 Sep 2020 20:40:03 +0200 Subject: [PATCH 113/120] Remove local env #211 --- src/lib/FreeC/Pass/SharingAnalysisPass.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib/FreeC/Pass/SharingAnalysisPass.hs b/src/lib/FreeC/Pass/SharingAnalysisPass.hs index 8ecb43b0..72cb2374 100644 --- a/src/lib/FreeC/Pass/SharingAnalysisPass.hs +++ b/src/lib/FreeC/Pass/SharingAnalysisPass.hs @@ -184,7 +184,7 @@ analyseSharingExpr varPats expr = do -- substitutions and applies the substitution on the expression. buildLet :: IR.Expr -> [IR.VarName] -> Converter IR.Expr buildLet expr [] = return expr -buildLet expr vars = localEnv $ do +buildLet expr vars = do let srcSpan = IR.exprSrcSpan expr (binds, substs) <- buildBinds srcSpan vars return (IR.Let srcSpan binds (applySubst (composeSubsts substs) expr) From 7f530a6238a884598878cdb15f3c37198e6e8b98 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 28 Sep 2020 20:40:29 +0200 Subject: [PATCH 114/120] Encapsulate effects when flattening expressions #211 --- src/lib/FreeC/Pass/FlattenExprPass.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/lib/FreeC/Pass/FlattenExprPass.hs b/src/lib/FreeC/Pass/FlattenExprPass.hs index 7af59877..d7ba3437 100644 --- a/src/lib/FreeC/Pass/FlattenExprPass.hs +++ b/src/lib/FreeC/Pass/FlattenExprPass.hs @@ -79,8 +79,8 @@ flatExpr (IR.App srcSpan lhs rhs typeScheme) typeArgs args = do encEffects <- shouldEncapsulateEffects lhs if encEffects then do - lhs' <- flatExpr lhs typeArgs args - rhs' <- flatExpr rhs typeArgs args + lhs' <- flatExpr lhs [] [] + rhs' <- flatExpr rhs [] [] return $ IR.App srcSpan lhs' rhs' typeScheme else flatExpr lhs typeArgs (rhs : args) flatExpr (IR.TypeAppExpr _ expr typeArg _) typeArgs args = flatExpr expr From 47dfdcb9370e671c7b878974ff3a6c9540ac1e93 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Tue, 29 Sep 2020 14:53:57 +0200 Subject: [PATCH 115/120] Apply HLint hint and format code #211 --- src/lib/FreeC/IR/Syntax/Expr.hs | 4 +--- src/lib/FreeC/Pass/FlattenExprPass.hs | 19 ++++++++++--------- src/lib/FreeC/Pass/SharingAnalysisPass.hs | 5 +++-- 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/lib/FreeC/IR/Syntax/Expr.hs b/src/lib/FreeC/IR/Syntax/Expr.hs index 53dbc84f..4ffe5681 100644 --- a/src/lib/FreeC/IR/Syntax/Expr.hs +++ b/src/lib/FreeC/IR/Syntax/Expr.hs @@ -180,9 +180,7 @@ visibleTypeApp = foldl . untypedTypeAppExpr getFuncName :: Expr -> VarName getFuncName (Var _ varName _) = varName getFuncName (App _ lhs _ _) = getFuncName lhs -getFuncName _ - = error "getFuncName: unexpected expression" - +getFuncName _ = error "getFuncName: unexpected expression" -- | Pretty instance for expressions. -- diff --git a/src/lib/FreeC/Pass/FlattenExprPass.hs b/src/lib/FreeC/Pass/FlattenExprPass.hs index d7ba3437..c2be5392 100644 --- a/src/lib/FreeC/Pass/FlattenExprPass.hs +++ b/src/lib/FreeC/Pass/FlattenExprPass.hs @@ -76,13 +76,13 @@ flatExpr (IR.Con srcSpan conName typeScheme) typeArgs args = buildLet flatExpr (IR.Var srcSpan varName typeScheme) typeArgs args = buildLet (IR.Var srcSpan varName typeScheme) typeArgs args flatExpr (IR.App srcSpan lhs rhs typeScheme) typeArgs args = do - encEffects <- shouldEncapsulateEffects lhs - if encEffects - then do - lhs' <- flatExpr lhs [] [] - rhs' <- flatExpr rhs [] [] - return $ IR.App srcSpan lhs' rhs' typeScheme - else flatExpr lhs typeArgs (rhs : args) + encEffects <- shouldEncapsulateEffects lhs + if encEffects + then do + lhs' <- flatExpr lhs [] [] + rhs' <- flatExpr rhs [] [] + return $ IR.App srcSpan lhs' rhs' typeScheme + else flatExpr lhs typeArgs (rhs : args) flatExpr (IR.TypeAppExpr _ expr typeArg _) typeArgs args = flatExpr expr (typeArg : typeArgs) args flatExpr (IR.If srcSpan e1 e2 e3 typeScheme) typeArgs args = do @@ -136,12 +136,13 @@ buildLet e' typeArgs args = do let srcSpan = IR.exprSrcSpan expr varPat = IR.VarPat srcSpan varIdent Nothing False bind = IR.Bind srcSpan varPat expr' - varName = (IR.UnQual $ IR.Ident varIdent) + varName = IR.UnQual $ IR.Ident varIdent var = IR.Var srcSpan varName (IR.exprTypeScheme expr) return (Just bind, var) -- | Whether an expression is an application of a function that encapsulates -- effects. shouldEncapsulateEffects :: IR.Expr -> Converter Bool -shouldEncapsulateEffects expr = inEnv $ encapsulatesEffects (IR.getFuncName expr) +shouldEncapsulateEffects expr = inEnv + $ encapsulatesEffects (IR.getFuncName expr) diff --git a/src/lib/FreeC/Pass/SharingAnalysisPass.hs b/src/lib/FreeC/Pass/SharingAnalysisPass.hs index 18ffb7fe..2e5dee48 100644 --- a/src/lib/FreeC/Pass/SharingAnalysisPass.hs +++ b/src/lib/FreeC/Pass/SharingAnalysisPass.hs @@ -96,7 +96,7 @@ sharingAnaylsisPass ast = do analyseSharingDecl :: IR.FuncDecl -> Converter IR.FuncDecl analyseSharingDecl funcDecl = do let declArgs = IR.funcDeclArgs funcDecl - rhs' <- ((analyseLocalSharing declArgs) >=> analyseSharingExpr declArgs) + rhs' <- (analyseLocalSharing declArgs >=> analyseSharingExpr declArgs) (IR.funcDeclRhs funcDecl) return funcDecl { IR.funcDeclRhs = rhs' } @@ -154,7 +154,8 @@ analyseLocalSharing varPats expr@(IR.App srcSpan lhs rhs typeScheme) = do -- | Whether an expression is an application of a function that encapsulates -- effects. shouldEncapsulateSharing :: IR.Expr -> Converter Bool -shouldEncapsulateSharing expr = inEnv $ encapsulatesEffects (IR.getFuncName expr) +shouldEncapsulateSharing expr = inEnv + $ encapsulatesEffects (IR.getFuncName expr) -- | Builds let expressions for variables with more than one occurrence -- for each argument of a function that encapsulates effects. From 2020e68659475593d5e3d5abe29f5e0ca93706f8 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Wed, 30 Sep 2020 07:38:07 +0200 Subject: [PATCH 116/120] Add Normalform and ShareableArgs instances for Property #211 --- base/coq/Test/QuickCheck.v | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/base/coq/Test/QuickCheck.v b/base/coq/Test/QuickCheck.v index 0c295b34..e4646aff 100644 --- a/base/coq/Test/QuickCheck.v +++ b/base/coq/Test/QuickCheck.v @@ -4,6 +4,18 @@ From Base Require Import Prelude. (* QuickCheck properties are implemented as Coq propositions. *) Definition Property (Shape : Type) (Pos : Shape -> Type) := Prop. +(* Normalform instance for Property. *) +Instance NormalformProperty (Shape : Type) (Pos : Shape -> Type) + : Normalform Shape Pos (Property Shape Pos) := { + nf' := pure +}. + +(* ShareableArgs instance for Property. *) +Instance ShareableArgsProperty (Shape : Type) (Pos : Shape -> Type) + : ShareableArgs Shape Pos (Property Shape Pos) := { + shareArgs := pure +}. + (* * [Testable] type class *) (* [class Testable prop where property :: prop -> Property] *) From 9f07a92371af4d49ff587c629023e8fdf65419d1 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Wed, 30 Sep 2020 07:38:42 +0200 Subject: [PATCH 117/120] Fix error in getFuncName #211 --- src/lib/FreeC/IR/Syntax/Expr.hs | 9 +++++---- src/lib/FreeC/Pass/FlattenExprPass.hs | 5 +++-- src/lib/FreeC/Pass/SharingAnalysisPass.hs | 11 +++++------ 3 files changed, 13 insertions(+), 12 deletions(-) diff --git a/src/lib/FreeC/IR/Syntax/Expr.hs b/src/lib/FreeC/IR/Syntax/Expr.hs index 4ffe5681..f9b76bec 100644 --- a/src/lib/FreeC/IR/Syntax/Expr.hs +++ b/src/lib/FreeC/IR/Syntax/Expr.hs @@ -176,11 +176,12 @@ conApp srcSpan = app srcSpan . untypedCon srcSpan visibleTypeApp :: SrcSpan -> Expr -> [Type] -> Expr visibleTypeApp = foldl . untypedTypeAppExpr --- | Returns the function or constructor name of an application. -getFuncName :: Expr -> VarName -getFuncName (Var _ varName _) = varName +-- | Returns the function name of a function application, or @Nothing@ if the +-- given expression is not a function application. +getFuncName :: Expr -> Maybe VarName +getFuncName (Var _ varName _) = Just varName getFuncName (App _ lhs _ _) = getFuncName lhs -getFuncName _ = error "getFuncName: unexpected expression" +getFuncName _ = Nothing -- | Pretty instance for expressions. -- diff --git a/src/lib/FreeC/Pass/FlattenExprPass.hs b/src/lib/FreeC/Pass/FlattenExprPass.hs index c2be5392..e0aabd87 100644 --- a/src/lib/FreeC/Pass/FlattenExprPass.hs +++ b/src/lib/FreeC/Pass/FlattenExprPass.hs @@ -143,6 +143,7 @@ buildLet e' typeArgs args = do -- | Whether an expression is an application of a function that encapsulates -- effects. shouldEncapsulateEffects :: IR.Expr -> Converter Bool -shouldEncapsulateEffects expr = inEnv - $ encapsulatesEffects (IR.getFuncName expr) +shouldEncapsulateEffects expr = case IR.getFuncName expr of + Nothing -> return False + Just name -> inEnv $ encapsulatesEffects name diff --git a/src/lib/FreeC/Pass/SharingAnalysisPass.hs b/src/lib/FreeC/Pass/SharingAnalysisPass.hs index 2e5dee48..fad3b4d3 100644 --- a/src/lib/FreeC/Pass/SharingAnalysisPass.hs +++ b/src/lib/FreeC/Pass/SharingAnalysisPass.hs @@ -56,7 +56,8 @@ -- -- After all subexpressions are checked the right hand side of the function -- declaration is checked as well. --- Variables already bound by @let@-bindings are not counted. +-- Variables already bound by @let@-bindings are not counted, and neither are +-- variables in the arguments of functions that encapsulate effects. -- -- == Postconditions -- @@ -154,8 +155,9 @@ analyseLocalSharing varPats expr@(IR.App srcSpan lhs rhs typeScheme) = do -- | Whether an expression is an application of a function that encapsulates -- effects. shouldEncapsulateSharing :: IR.Expr -> Converter Bool -shouldEncapsulateSharing expr = inEnv - $ encapsulatesEffects (IR.getFuncName expr) +shouldEncapsulateSharing expr = case IR.getFuncName expr of + Nothing -> return False + Just name -> inEnv $ encapsulatesEffects name -- | Builds let expressions for variables with more than one occurrence -- for each argument of a function that encapsulates effects. @@ -264,9 +266,6 @@ countVarNames (IR.Let _ binds e _) = do map2 <- foldM (\m bind -> mergeMap m <$> countVarNames (IR.bindExpr bind)) Map.empty binds let completeMap = mergeMap map1 map2 - {- completeMap = countVarNames e - `mergeMap` foldr (mergeMap . countVarNames . IR.bindExpr) Map.empty - binds-} return $ completeMap `Map.withoutKeys` Set.fromList bindVars mergeMap From 91f4430da6257c7184b1aabaa0dc5a0e3517178c Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Wed, 30 Sep 2020 07:47:44 +0200 Subject: [PATCH 118/120] Format code #211 --- src/lib/FreeC/Pass/FlattenExprPass.hs | 4 ++-- src/lib/FreeC/Pass/SharingAnalysisPass.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/lib/FreeC/Pass/FlattenExprPass.hs b/src/lib/FreeC/Pass/FlattenExprPass.hs index e0aabd87..2568575b 100644 --- a/src/lib/FreeC/Pass/FlattenExprPass.hs +++ b/src/lib/FreeC/Pass/FlattenExprPass.hs @@ -144,6 +144,6 @@ buildLet e' typeArgs args = do -- effects. shouldEncapsulateEffects :: IR.Expr -> Converter Bool shouldEncapsulateEffects expr = case IR.getFuncName expr of - Nothing -> return False - Just name -> inEnv $ encapsulatesEffects name + Nothing -> return False + Just name -> inEnv $ encapsulatesEffects name diff --git a/src/lib/FreeC/Pass/SharingAnalysisPass.hs b/src/lib/FreeC/Pass/SharingAnalysisPass.hs index fad3b4d3..4e09a3d3 100644 --- a/src/lib/FreeC/Pass/SharingAnalysisPass.hs +++ b/src/lib/FreeC/Pass/SharingAnalysisPass.hs @@ -156,8 +156,8 @@ analyseLocalSharing varPats expr@(IR.App srcSpan lhs rhs typeScheme) = do -- effects. shouldEncapsulateSharing :: IR.Expr -> Converter Bool shouldEncapsulateSharing expr = case IR.getFuncName expr of - Nothing -> return False - Just name -> inEnv $ encapsulatesEffects name + Nothing -> return False + Just name -> inEnv $ encapsulatesEffects name -- | Builds let expressions for variables with more than one occurrence -- for each argument of a function that encapsulates effects. From 354e51f76c5532e6cd69652128d220f886c9caeb Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Wed, 30 Sep 2020 08:01:27 +0200 Subject: [PATCH 119/120] Adjust SharingAnalysisPassTests #211 --- src/test/FreeC/Pass/SharingAnalysisPassTests.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/test/FreeC/Pass/SharingAnalysisPassTests.hs b/src/test/FreeC/Pass/SharingAnalysisPassTests.hs index f28d4968..72c8ef87 100644 --- a/src/test/FreeC/Pass/SharingAnalysisPassTests.hs +++ b/src/test/FreeC/Pass/SharingAnalysisPassTests.hs @@ -2,6 +2,7 @@ module FreeC.Pass.SharingAnalysisPassTests ( testSharingAnalysisPass ) where import Test.Hspec +import FreeC.IR.Syntax as IR import FreeC.Monad.Class.Testable import FreeC.Pass.SharingAnalysisPass import FreeC.Test.Expectations @@ -16,7 +17,7 @@ testAnalyseSharingExpr :: Spec testAnalyseSharingExpr = context "analyseSharingExpr" $ do it "introduces 'let'-expression for shared variables" $ shouldSucceedWith $ do input <- parseTestExpr "f x x" - varName <- parseTestQName "x" + let varName = IR.toVarPat "x" expectedOutput <- parseTestExpr "let {y = x} in f y y" output <- analyseSharingExpr [varName] input return $ output `shouldBeSimilarTo` expectedOutput @@ -28,7 +29,7 @@ testAnalyseSharingExpr = context "analyseSharingExpr" $ do $ shouldSucceedWith $ do input <- parseTestExpr "if b then x else x" - varName <- parseTestQName "x" + let varName = IR.toVarPat "x" output <- analyseSharingExpr [varName] input return $ output `shouldBeSimilarTo` input @@ -41,7 +42,7 @@ testAnalyseLocalSharing = context "analyseLocalSharing" $ do expectedOutput <- parseTestExpr "case e of {Nothing -> 0; Just x -> let {y = x} in f y y}" --expectedOutput <- parseTestExpr "case e of {Nothing -> 0; Just x -> let {y = x} in f y y}" - output <- analyseLocalSharing input + output <- analyseLocalSharing [] input --return $ output `shouldBeSimilarTo` expectedOutput return $ expectedOutput `shouldBeSimilarTo` output it "introduces 'let'-expression for shared variables from 'lambda'-expr" @@ -49,12 +50,12 @@ testAnalyseLocalSharing = context "analyseLocalSharing" $ do $ do input <- parseTestExpr "\\x -> f x x" expectedOutput <- parseTestExpr "\\x -> let {y = x} in f y y" - output <- analyseLocalSharing input + output <- analyseLocalSharing [] input return $ output `shouldBeSimilarTo` expectedOutput it "introduces 'let'-expressions for nested expressions" $ shouldSucceedWith $ do input <- parseTestExpr "\\y -> \\x -> f x x" expectedOutput <- parseTestExpr "\\y -> \\x -> let {z = x} in f z z" - output <- analyseLocalSharing input + output <- analyseLocalSharing [] input return $ output `shouldBeSimilarTo` expectedOutput From 6b31dc0b744f2704380e42edd4c4b7d67274407b Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Wed, 30 Sep 2020 12:22:43 +0200 Subject: [PATCH 120/120] Fix bug in analysis of case expression variable counting #211 --- src/lib/FreeC/Pass/SharingAnalysisPass.hs | 6 ++---- src/test/FreeC/Pass/SharingAnalysisPassTests.hs | 2 +- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/src/lib/FreeC/Pass/SharingAnalysisPass.hs b/src/lib/FreeC/Pass/SharingAnalysisPass.hs index 4e09a3d3..50ee3193 100644 --- a/src/lib/FreeC/Pass/SharingAnalysisPass.hs +++ b/src/lib/FreeC/Pass/SharingAnalysisPass.hs @@ -251,11 +251,9 @@ countVarNames IR.IntLiteral {} = return $ Map.empty countVarNames (IR.Case _ e alts _) = do let altVars = concatMap (map IR.varPatQName . IR.altVarPats) alts map1 <- countVarNames e - map2 <- foldM (\m alt -> mergeMap m <$> countVarNames (IR.altRhs alt)) - Map.empty alts - map3 <- foldM (\m alt -> Map.unionWith max m + map2 <- foldM (\m alt -> Map.unionWith max m <$> countVarNames (IR.altRhs alt)) Map.empty alts - let completeMap = map1 `mergeMap` map2 `mergeMap` map3 + let completeMap = map1 `mergeMap` map2 return $ completeMap `Map.withoutKeys` Set.fromList altVars countVarNames (IR.Lambda _ args rhs _) = do rhsVars <- countVarNames rhs diff --git a/src/test/FreeC/Pass/SharingAnalysisPassTests.hs b/src/test/FreeC/Pass/SharingAnalysisPassTests.hs index 72c8ef87..293e942e 100644 --- a/src/test/FreeC/Pass/SharingAnalysisPassTests.hs +++ b/src/test/FreeC/Pass/SharingAnalysisPassTests.hs @@ -2,7 +2,7 @@ module FreeC.Pass.SharingAnalysisPassTests ( testSharingAnalysisPass ) where import Test.Hspec -import FreeC.IR.Syntax as IR +import FreeC.IR.Syntax as IR import FreeC.Monad.Class.Testable import FreeC.Pass.SharingAnalysisPass import FreeC.Test.Expectations