From f607aa57db723cf072bfd3146df9dcb8020b3168 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Wed, 26 Aug 2020 10:09:17 +0200 Subject: [PATCH 01/62] 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 02/62] 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 03/62] 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 04/62] 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 05/62] 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 06/62] 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 07/62] 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 08/62] 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 09/62] 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 10/62] 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 11/62] 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 12/62] 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 13/62] 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 14/62] 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 15/62] 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 16/62] 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 17/62] 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 18/62] 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 2b1aa90d2d2a25567d0cf0d761e5365196946032 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Thu, 10 Sep 2020 12:18:26 +0200 Subject: [PATCH 19/62] 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 20/62] 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 21/62] 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 22/62] 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 23/62] 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 24/62] 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 6d0da01a566ee3b8def30d2684ae7da2029904bd Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 14 Sep 2020 13:18:56 +0200 Subject: [PATCH 25/62] 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 26/62] 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 8b02b8914fb28bc930fe162c06f64b24506b7645 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 14 Sep 2020 15:49:49 +0200 Subject: [PATCH 27/62] 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 cc75a40ce0329fab1e75d17e6f96739a05779cfb Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 14 Sep 2020 16:04:09 +0200 Subject: [PATCH 28/62] 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 29/62] 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 30/62] 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 31/62] 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 bc134ba4e66cd6ab72ef0008cbd8999dc0368852 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Tue, 15 Sep 2020 09:55:45 +0200 Subject: [PATCH 32/62] 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 02a3b00d8f66b42bd2b84ecc92b6974c37efba96 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Tue, 15 Sep 2020 18:39:17 +0200 Subject: [PATCH 33/62] 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 34/62] 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 35/62] 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 36/62] 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 37/62] 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 38/62] 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 39/62] 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 40/62] 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 41/62] 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 42/62] 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 43/62] 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 a983129815c38e47ca5459ab4f054721c526c7dd Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 20 Sep 2020 11:23:02 +0200 Subject: [PATCH 44/62] 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 45/62] 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 46/62] 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 47/62] 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 48/62] 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 49/62] 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 50/62] 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 51/62] 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 52/62] 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 53/62] 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 91328dfc04f6dd24ee43cff550b1a3d112c6ec73 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Sun, 20 Sep 2020 15:44:08 +0200 Subject: [PATCH 54/62] 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 b85dca3cea3dd8f809f485046573ade0ff7c25ad Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Fri, 25 Sep 2020 11:52:40 +0200 Subject: [PATCH 55/62] 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 56/62] 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 57/62] 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 c8137c87a0bcd5db69cacfbcec512b2cbcc75887 Mon Sep 17 00:00:00 2001 From: Maja Reichert Date: Mon, 28 Sep 2020 10:56:27 +0200 Subject: [PATCH 58/62] 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 59/62] 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 60/62] 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 61/62] 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 62/62] 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}"