Commit 82fb2c57 authored by Michael Hanus's avatar Michael Hanus
Browse files

Merge branch 'libs_refactor'

parents 13e77659 5e86f1e5
Copyright (c) 2017, Michael Hanus
Copyright (c) 2020, Michael Hanus
All rights reserved.
Redistribution and use in source and binary forms, with or without
......
......@@ -2,15 +2,4 @@ flatcurry-annotated
===================
This package contain libraries to represent FlatCurry programs with
arbitrary annotations. Furthermore, it contains libraries to annotate
each expression occurring in a given FlatCurry program with type
information. For this purpose, the library `FlatCurry.Annotated.TypeInference`
exports a main operation
inferProg :: Prog -> IO (Either String (AProg TypeExpr))
which annotates a FlatCurry program with type information.
A previous version of these libraries were part of the
PAKCS/KiCS2 distributions.
arbitrary annotations.
{
"name": "flatcurry-annotated",
"version": "2.0.0",
"version": "3.3.0",
"author": "Michael Hanus <mh@informatik.uni-kiel.de>, Jonas Oberschweiber <jonas@oberschweiber.com>, Bjoern Peemoeller <bjp@informatik.uni-kiel.de>",
"maintainer": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "Libraries to represent FlatCurry programs with arbitrary annotations",
"category": [ "Metaprogramming" ],
"description": "This package contain libraries to represent FlatCurry programs with arbitrary annotations. Furthermore, it contains libraries to annotate each expression occurring in a given FlatCurry program with type information.",
"category": [ "Metaprogramming" ],
"description": "This package contain libraries to represent FlatCurry programs with arbitrary annotations.",
"license": "BSD-3-Clause",
"licenseFile": "LICENSE",
"dependencies": {
"base" : ">= 1.0.0, < 2.0.0",
"currypath" : ">= 0.0.1",
"finite-map" : ">= 0.0.1",
"flatcurry" : ">= 2.0.0",
"frontend-exec": ">= 0.0.1",
"rewriting" : ">= 2.0.0",
"scc" : ">= 0.0.1",
"wl-pprint" : ">= 0.0.1"
"base" : ">= 3.0.0, < 4.0.0",
"currypath" : ">= 3.0.0, < 4.0.0",
"directory" : ">= 3.0.0, < 4.0.0",
"filepath" : ">= 3.0.0, < 4.0.0",
"flatcurry" : ">= 3.0.0, < 4.0.0",
"wl-pprint" : ">= 3.0.0, < 4.0.0"
},
"compilerCompatibility": {
"pakcs": ">= 2.0.0, < 3.0.0",
"kics2": ">= 2.0.0, < 3.0.0"
"pakcs" : ">= 3.3.0, < 4.0.0",
"kics2" : ">= 3.0.0, < 4.0.0",
"curry2go": ">= 1.0.0"
},
"exportedModules": [ "FlatCurry.Annotated.Types",
"FlatCurry.Annotated.Files",
"FlatCurry.Annotated.Goodies",
"FlatCurry.Annotated.Pretty",
"FlatCurry.Annotated.TypeSubst",
"FlatCurry.Annotated.TypeInference" ],
"FlatCurry.Annotated.Pretty" ],
"source": {
"git": "https://git.ps.informatik.uni-kiel.de/curry-packages/flatcurry-annotated.git",
"tag": "$version"
......
------------------------------------------------------------------------------
--- This library defines I/O actions to read and write
--- type-annotated FlatCurry programs.
--- annotated FlatCurry programs.
---
--- @author Michael Hanus
--- @version July 2020
--- @version December 2020
------------------------------------------------------------------------------
module FlatCurry.Annotated.Files where
import Directory ( doesFileExist )
import FileGoodies ( getFileInPath)
import FilePath ( takeFileName, (</>), (<.>) )
import ReadShowTerm ( readUnqualifiedTerm, showTerm ) -- for faster reading
import System.CurryPath ( inCurrySubdir, stripCurrySuffix
, lookupModuleSourceInLoadPath, getLoadPathForModule
)
import System.FrontendExec ( FrontendParams, FrontendTarget (..)
, defaultParams, setQuiet, callFrontendWithParams )
import System.CurryPath ( lookupModuleSourceInLoadPath
, inCurrySubdir, stripCurrySuffix )
import System.Directory ( doesFileExist )
import System.FilePath ( (</>), (<.>) )
import FlatCurry.Annotated.Types
--- Transforms a name of a Curry program (with or without suffix ".curry"
--- or ".lcurry") into the name of the file containing the
--- corresponding type-annotated FlatCurry program.
typedFlatCurryFileName :: String -> String
typedFlatCurryFileName prog = inCurrySubdir (stripCurrySuffix prog) <.> "tfcy"
--- corresponding annotated FlatCurry program.
annotatedFlatCurryFileName :: String -> String
annotatedFlatCurryFileName prog =
inCurrySubdir (stripCurrySuffix prog) <.> "afcy"
--- Gets the standard type-annotated FlatCurry file location
--- Gets the standard annotated FlatCurry file location
--- for a given Curry module name.
--- The Curry source program must exist in the Curry load path,
--- otherwise an error is raised.
typedFlatCurryFilePath :: String -> IO String
typedFlatCurryFilePath mname = do
annotatedFlatCurryFilePath :: String -> IO String
annotatedFlatCurryFilePath mname = do
mbsrc <- lookupModuleSourceInLoadPath mname
case mbsrc of
Nothing -> error $ "Curry source file for module '" ++ mname ++
"' not found!"
Just (dir,_) -> return (typedFlatCurryFileName (dir </> mname))
--- I/O action which parses a Curry program and returns the corresponding
--- type-annotated FlatCurry program.
--- The argument is the module path (without suffix ".curry"
--- or ".lcurry") and the result is a type-annotated FlatCurry term
--- representing this program.
readTypedFlatCurry :: String -> IO (AProg TypeExpr)
readTypedFlatCurry progname =
readTypedFlatCurryWithParseOptions progname (setQuiet True defaultParams)
--- I/O action which parses a Curry program
--- with respect to some parser options and returns the
--- corresponding FlatCurry program.
--- This I/O action is used by `readTypedFlatCurry`.
--- @param progfile - the program file name (without suffix ".curry")
--- @param options - parameters passed to the front end
readTypedFlatCurryWithParseOptions :: String -> FrontendParams
-> IO (AProg TypeExpr)
readTypedFlatCurryWithParseOptions progname options = do
mbsrc <- lookupModuleSourceInLoadPath progname
case mbsrc of
Nothing -> do -- no source file, try to find FlatCurry file in load path:
loadpath <- getLoadPathForModule progname
filename <- getFileInPath (typedFlatCurryFileName (takeFileName progname))
[""]
loadpath
readTypedFlatCurryFile filename
Just (dir,_) -> do
callFrontendWithParams TFCY options progname
readTypedFlatCurryFile
(typedFlatCurryFileName (dir </> takeFileName progname))
Just (dir,_) -> return (annotatedFlatCurryFileName (dir </> mname))
--- Reads a type-annotated FlatCurry program from a file in `.tfcy` format
--- where the file name is provided as the argument.
readTypedFlatCurryFile :: String -> IO (AProg TypeExpr)
readTypedFlatCurryFile filename = do
filecontents <- readTypedFlatCurryFileRaw filename
-- ...with generated Read class instances (slow!):
--return (read filecontents)
-- ...with built-in generic read operation (faster):
return (readUnqualifiedTerm ["FlatCurry.Annotated.Types", "FlatCurry.Types",
"Prelude"]
filecontents)
readAnnotatedFlatCurryFile :: Read a => String -> IO (AProg a)
readAnnotatedFlatCurryFile filename = do
filecontents <- readAnnotatedFlatCurryFileRaw filename
return (read filecontents)
where
readTypedFlatCurryFileRaw fname = do
extfcy <- doesFileExist fname
if extfcy
readAnnotatedFlatCurryFileRaw fname = do
exafcy <- doesFileExist fname
if exafcy
then readFile fname
else do
let subdirfilename = inCurrySubdir fname
exdirtfcy <- doesFileExist subdirfilename
if exdirtfcy
exdirafcy <- doesFileExist subdirfilename
if exdirafcy
then readFile subdirfilename
else error $ "EXISTENCE ERROR: Typed FlatCurry file '" ++
else error $ "EXISTENCE ERROR: Annotated FlatCurry file '" ++
fname ++ "' does not exist"
--- Writes a type-annotated FlatCurry program into a file in `.tfcy` format.
--- Writes an annotated FlatCurry program into a file in `.afcy` format.
--- The file is written in the standard location for intermediate files,
--- i.e., in the 'typedFlatCurryFileName' relative to the directory of the
--- i.e., in the 'annotatedFlatCurryFileName' relative to the directory of the
--- Curry source program (which must exist!).
writeTypedFlatCurry :: AProg TypeExpr -> IO ()
writeTypedFlatCurry prog@(AProg mname _ _ _ _) = do
fname <- typedFlatCurryFilePath mname
writeTypedFlatCurryFile fname prog
writeAnnotatedFlatCurry :: Show a => AProg a -> IO ()
writeAnnotatedFlatCurry prog@(AProg mname _ _ _ _) = do
fname <- annotatedFlatCurryFilePath mname
writeAnnotatedFlatCurryFile fname prog
--- Writes a type-annotated FlatCurry program into a file in ".tfcy" format.
--- Writes an annotated FlatCurry program into a file in ".afcy" format.
--- The first argument must be the name of the target file
--- (with suffix `.fcy`).
writeTypedFlatCurryFile :: String -> AProg TypeExpr -> IO ()
writeTypedFlatCurryFile file prog = writeFile file (showTerm prog)
--- (with suffix `.afcy`).
writeAnnotatedFlatCurryFile :: Show a => String -> AProg a -> IO ()
writeAnnotatedFlatCurryFile file prog = writeFile file (show prog)
......@@ -117,74 +117,90 @@ rnmProg name p = updProgName (const name) (updQNamesInProg rnm p)
-- Selectors
--- transform type declaration
trType :: (QName -> Visibility -> [TVarIndex] -> [ConsDecl] -> a) ->
(QName -> Visibility -> [TVarIndex] -> TypeExpr -> a) -> TypeDecl -> a
trType typ _ (Type name vis params cs) = typ name vis params cs
trType _ typesyn (TypeSyn name vis params syn) = typesyn name vis params syn
trType :: (QName -> Visibility -> [(TVarIndex, Kind)] -> [ConsDecl] -> a) ->
(QName -> Visibility -> [(TVarIndex, Kind)] -> TypeExpr -> a) ->
(QName -> Visibility -> [(TVarIndex, Kind)] -> NewConsDecl -> a) -> TypeDecl -> a
trType typ _ _ (Type name vis params cs) = typ name vis params cs
trType _ typesyn _ (TypeSyn name vis params syn) = typesyn name vis params syn
trType _ _ typenew (TypeNew name vis params c) = typenew name vis params c
--- get name of type declaration
typeName :: TypeDecl -> QName
typeName = trType (\name _ _ _ -> name) (\name _ _ _ -> name)
typeName = trType (\name _ _ _ -> name) (\name _ _ _ -> name) (\name _ _ _ -> name)
--- get visibility of type declaration
typeVisibility :: TypeDecl -> Visibility
typeVisibility = trType (\_ vis _ _ -> vis) (\_ vis _ _ -> vis)
typeVisibility = trType (\_ vis _ _ -> vis) (\_ vis _ _ -> vis) (\_ vis _ _ -> vis)
--- get type parameters of type declaration
typeParams :: TypeDecl -> [TVarIndex]
typeParams = trType (\_ _ params _ -> params) (\_ _ params _ -> params)
typeParams :: TypeDecl -> [(TVarIndex, Kind)]
typeParams = trType (\_ _ params _ -> params) (\_ _ params _ -> params) (\_ _ params _ -> params)
--- get constructor declarations from type declaration
typeConsDecls :: TypeDecl -> [ConsDecl]
typeConsDecls = trType (\_ _ _ cs -> cs) failed
typeConsDecls = trType (\_ _ _ cs -> cs) failed failed
--- get synonym of type declaration
typeSyn :: TypeDecl -> TypeExpr
typeSyn = trType failed (\_ _ _ syn -> syn)
typeSyn = trType failed (\_ _ _ syn -> syn) failed
--- is type declaration a basic data type?
isTypeData :: TypeDecl -> Bool
isTypeData = trType (\_ _ _ _ -> True) (\_ _ _ _ -> False) (\_ _ _ _ -> False)
--- is type declaration a type synonym?
isTypeSyn :: TypeDecl -> Bool
isTypeSyn = trType (\_ _ _ _ -> False) (\_ _ _ _ -> True)
isTypeSyn = trType (\_ _ _ _ -> False) (\_ _ _ _ -> True) (\_ _ _ _ -> False)
--- is type declaration a newtype?
isTypeNew :: TypeDecl -> Bool
isTypeNew = trType (\_ _ _ _ -> False) (\_ _ _ _ -> False) (\_ _ _ _ -> True)
-- Update Operations
--- update type declaration
updType :: (QName -> QName) ->
(Visibility -> Visibility) ->
([TVarIndex] -> [TVarIndex]) ->
([(TVarIndex, Kind)] -> [(TVarIndex, Kind)]) ->
([ConsDecl] -> [ConsDecl]) ->
(NewConsDecl -> NewConsDecl) ->
(TypeExpr -> TypeExpr) -> TypeDecl -> TypeDecl
updType fn fv fp fc fs = trType typ typesyn
updType fn fv fp fc fnc fs = trType typ typesyn typenew
where
typ name vis params cs = Type (fn name) (fv vis) (fp params) (fc cs)
typesyn name vis params syn = TypeSyn (fn name) (fv vis) (fp params) (fs syn)
typenew name vis params nc = TypeNew (fn name) (fv vis) (fp params) (fnc nc)
--- update name of type declaration
updTypeName :: Update TypeDecl QName
updTypeName f = updType f id id id id
updTypeName f = updType f id id id id id
--- update visibility of type declaration
updTypeVisibility :: Update TypeDecl Visibility
updTypeVisibility f = updType id f id id id
updTypeVisibility f = updType id f id id id id
--- update type parameters of type declaration
updTypeParams :: Update TypeDecl [TVarIndex]
updTypeParams f = updType id id f id id
updTypeParams :: Update TypeDecl [(TVarIndex, Kind)]
updTypeParams f = updType id id f id id id
--- update constructor declarations of type declaration
updTypeConsDecls :: Update TypeDecl [ConsDecl]
updTypeConsDecls f = updType id id id f id
updTypeConsDecls f = updType id id id f id id
--- update newtype constructor declaration of type declaration
updTypeNewConsDecl :: Update TypeDecl NewConsDecl
updTypeNewConsDecl f = updType id id id id f id
--- update synonym of type declaration
updTypeSynonym :: Update TypeDecl TypeExpr
updTypeSynonym = updType id id id id
updTypeSynonym = updType id id id id id
-- Auxiliary Functions
--- update all qualified names in type declaration
updQNamesInType :: Update TypeDecl QName
updQNamesInType f
= updType f id id (map (updQNamesInConsDecl f)) (updQNamesInTypeExpr f)
= updType f id id (map (updQNamesInConsDecl f)) (updQNamesInNewConsDecl f) (updQNamesInTypeExpr f)
-- ConsDecl ------------------------------------------------------------------
......@@ -243,6 +259,51 @@ updConsArgs = updCons id id id
updQNamesInConsDecl :: Update ConsDecl QName
updQNamesInConsDecl f = updCons f id id (map (updQNamesInTypeExpr f))
-- NewConsDecl ------------------------------------------------------------------
--- transform newtype constructor declaration
trNewCons :: (QName -> Visibility -> TypeExpr -> a) -> NewConsDecl -> a
trNewCons cons (NewCons name vis arg) = cons name vis arg
-- get argument of newtype constructor declaration
newConsArg :: NewConsDecl -> TypeExpr
newConsArg = trNewCons (\_ _ arg -> arg)
-- get name of newtype constructor declaration
newConsName :: NewConsDecl -> QName
newConsName = trNewCons (\name _ _ -> name)
-- get visibility of newtype constructor declaration
newConsVisibility :: NewConsDecl -> Visibility
newConsVisibility = trNewCons (\_ vis _ -> vis)
-- Update Operations
--- update newtype constructor declaration
updNewCons :: (QName -> QName) ->
(Visibility -> Visibility) ->
(TypeExpr -> TypeExpr) -> NewConsDecl -> NewConsDecl
updNewCons fn fv fas = trNewCons newcons
where
newcons name vis args = NewCons (fn name) (fv vis) (fas args)
--- update name of newtype constructor declaration
updNewConsName :: Update NewConsDecl QName
updNewConsName f = updNewCons f id id
--- update visibility of newtype constructor declaration
updNewConsVisibility :: Update NewConsDecl Visibility
updNewConsVisibility f = updNewCons id f id
--- update argument of newtype constructor declaration
updNewConsArg :: Update NewConsDecl TypeExpr
updNewConsArg = updNewCons id id
-- Auxiliary Functions
updQNamesInNewConsDecl :: Update NewConsDecl QName
updQNamesInNewConsDecl f = updNewCons f id (updQNamesInTypeExpr f)
-- TypeExpr ------------------------------------------------------------------
-- Selectors
......@@ -281,8 +342,8 @@ tConsArgs texpr = case texpr of
trTypeExpr :: (TVarIndex -> a) ->
(QName -> [a] -> a) ->
(a -> a -> a) ->
([TVarIndex] -> a -> a) -> TypeExpr -> a
trTypeExpr tvar _ _ _ (TVar n) = tvar n
([(TVarIndex, Kind)] -> a -> a) -> TypeExpr -> a
trTypeExpr tvar _ _ _ (TVar tv) = tvar tv
trTypeExpr tvar tcons functype foralltype (TCons name args)
= tcons name (map (trTypeExpr tvar tcons functype foralltype) args)
trTypeExpr tvar tcons functype foralltype (FuncType from to)
......@@ -328,7 +389,8 @@ updFuncTypes :: (TypeExpr -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr
updFuncTypes functype = trTypeExpr TVar TCons functype ForallType
--- update all forall types
updForallTypes :: ([TVarIndex] -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr
updForallTypes :: ([(TVarIndex, Kind)] -> TypeExpr -> TypeExpr)
-> TypeExpr -> TypeExpr
updForallTypes = trTypeExpr TVar TCons FuncType
-- Auxiliary Functions
......@@ -1010,4 +1072,3 @@ unAnnExpr = trExpr var lit comb lett fre or cse branch typed
unAnnPattern :: APattern _ -> FC.Pattern
unAnnPattern = trPattern (\_ qn vs -> FC.Pattern (fst qn) (map fst vs))
(\_ l -> FC.LPattern l)
......@@ -9,6 +9,8 @@
--- --------------------------------------------------------------------------
module FlatCurry.Annotated.Pretty where
import Prelude hiding ( empty )
import Text.Pretty
import FlatCurry.Annotated.Types
......@@ -42,6 +44,9 @@ ppTypeExport (Type qn vis _ cs)
ppTypeExport (TypeSyn qn vis _ _ )
| vis == Private = empty
| otherwise = ppPrefixOp qn
ppTypeExport (TypeNew qn vis _ (NewCons _ vis' _))
| vis == Private || vis' == Private = empty
| otherwise = ppPrefixOp qn <+> text "(..)"
--- pretty-print the export list of constructors
ppConsExports :: [ConsDecl] -> [Doc]
......@@ -80,9 +85,11 @@ ppTypeDecls = compose (<$+$>) . map ppTypeDecl
--- pretty-print a type declaration
ppTypeDecl :: TypeDecl -> Doc
ppTypeDecl (Type qn _ vs cs) = indent $ text "data" <+> ppQName qn
<+> hsep (map ppTVarIndex vs) <$$> ppConsDecls cs
<+> hsep (map (ppTVarIndex . fst) vs) <$$> ppConsDecls cs
ppTypeDecl (TypeSyn qn _ vs ty) = indent $ text "type" <+> ppQName qn
<+> hsep (map ppTVarIndex vs) </> equals <+> ppTypeExp ty
<+> hsep (map (ppTVarIndex . fst) vs) </> equals <+> ppTypeExp ty
ppTypeDecl (TypeNew qn _ vs c) = indent $ text "newtype" <+> ppQName qn
<+> hsep (empty : map (ppTVarIndex . fst) vs) $$ ppNewConsDecl c
--- pretty-print the constructor declarations
ppConsDecls :: [ConsDecl] -> Doc
......@@ -93,6 +100,10 @@ ppConsDecls cs = vsep $
ppConsDecl :: ConsDecl -> Doc
ppConsDecl (Cons qn _ _ tys) = hsep $ ppPrefixOp qn : map (ppTypeExpr 2) tys
--- pretty print a single newtype constructor
ppNewConsDecl :: NewConsDecl -> Doc
ppNewConsDecl (NewCons qn _ ty) = hsep [ppPrefixOp qn, ppTypeExpr 2 ty]
--- pretty a top-level type expression
ppTypeExp :: TypeExpr -> Doc
ppTypeExp = ppTypeExpr 0
......@@ -112,10 +123,10 @@ ppTypeExpr p (ForallType vs ty)
| otherwise = parensIf (p > 0) $ ppQuantifiedVars vs <+> ppTypeExpr 0 ty
--- pretty-print explicitly quantified type variables
ppQuantifiedVars :: [TVarIndex] -> Doc
ppQuantifiedVars :: [(TVarIndex, Kind)] -> Doc
ppQuantifiedVars vs
| null vs = empty
| otherwise = text "forall" <+> hsep (map ppTVarIndex vs) <+> char '.'
| null vs = empty
| otherwise = text "forall" <+> hsep (map (ppTVarIndex . fst) vs) <+> char '.'
--- pretty-print a type variable
ppTVarIndex :: TVarIndex -> Doc
......
This diff is collapsed.
--- ----------------------------------------------------------------------------
--- Type substitutions on type-annotated AnnotatedFlatCurry
---
--- @author Bjoern Peemoeller
--- @version September 2014
--- @category meta
--- ----------------------------------------------------------------------------
module FlatCurry.Annotated.TypeSubst where
import Data.FiniteMap
import FlatCurry.Annotated.Types
--- The (abstract) data type for substitutions on TypeExpr.
type AFCSubst = FM TVarIndex TypeExpr
showAFCSubst :: AFCSubst -> String
showAFCSubst = unlines . map showOne . fmToList
where showOne (k, v) = show k ++ " -> " ++ show v
--- The empty substitution
emptyAFCSubst :: AFCSubst
emptyAFCSubst = emptyFM (<)
--- Searches the substitution for a mapping from the given variable index
--- to a term.
---
--- @param subst - the substitution to search
--- @param i - the index to search for
--- @return the found type expression or Nothing
lookupAFCSubst :: AFCSubst -> TVarIndex -> Maybe TypeExpr
lookupAFCSubst = lookupFM
-- -----------------------------------------------------------------------------
-- Functions for applying substitutions to expressions
-- -----------------------------------------------------------------------------
--- Applies a substitution to a function.
---
--- @param sub - the substitution
--- @param f - the function
--- @return the function with the substitution applied
substFunc :: AFCSubst -> AFuncDecl TypeExpr -> AFuncDecl TypeExpr
substFunc sub (AFunc f a v ty r) = AFunc f a v (subst sub ty) (substRule sub r)
--- Applies a substitution to a type expression.
---
--- @param sub - the substitution
--- @param r - the rule
--- @return the rule with the substitution applied
substRule :: AFCSubst -> ARule TypeExpr -> ARule TypeExpr
substRule sub (ARule ty vs e) = ARule (subst sub ty) (map (substSnd sub) vs)
(substExpr sub e)
substRule sub (AExternal ty s) = AExternal (subst sub ty) s
--- Applies a substitution to a type expression.
---
--- @param sub - the substitution
--- @param ex - the expression
--- @return the expression with the substitution applied
substExpr :: AFCSubst -> AExpr TypeExpr -> AExpr TypeExpr
substExpr sub (AComb ty t f ps) = AComb (subst sub ty) t (substSnd sub f)
(map (substExpr sub) ps)
substExpr sub (AVar ty k) = AVar (subst sub ty) k
substExpr sub (ACase ty t e bs) = ACase (subst sub ty) t (substExpr sub e)
(map (substBranch sub) bs)
substExpr sub (ALit ty l) = ALit (subst sub ty) l
substExpr sub (AOr ty a b) = AOr (subst sub ty) (substExpr sub a)
(substExpr sub b)
substExpr sub (ALet ty bs e) = ALet (subst sub ty) (map substBinding bs)
(substExpr sub e)
where substBinding (v, b) = (substSnd sub v, substExpr sub b)
substExpr sub (AFree ty vs e) = AFree (subst sub ty) (map (substSnd sub) vs)
(substExpr sub e)
substExpr sub (ATyped ty e ty') = ATyped (subst sub ty) (substExpr sub e)
(subst sub ty')
substSnd :: AFCSubst -> (a, TypeExpr) -> (a, TypeExpr)
substSnd sub (a, ty) = (a, subst sub ty)
--- Applies a substitution to a branch expression.
---
--- @param sub - the substitution
--- @param b - the branch
--- @return the branch with the substitution applied
substBranch :: AFCSubst -> ABranchExpr TypeExpr -> ABranchExpr TypeExpr
substBranch sub (ABranch p e) = ABranch (substPattern sub p) (substExpr sub e)
--- Applies a substitution to a pattern.
---
--- @param sub - the substitution
--- @param p - the pattern
--- @return the pattern with the substitution applied
substPattern :: AFCSubst -> APattern TypeExpr -> APattern TypeExpr
substPattern sub (APattern t f vs) = APattern (subst sub t) (substSnd sub f)
(map (substSnd sub) vs)
substPattern sub (ALPattern t l) = ALPattern (subst sub t) l
--- Looks up a type in a substitution and converts the resulting Term
--- to a TypeExpr. Returns a given default value if the lookup fails.
---
--- @param t - the type to look up
--- @param e - the default value
--- @param sub - the substitution to search in
--- @return either the looked-up and converted type or the default type
subst :: AFCSubst -> TypeExpr -> TypeExpr
subst sub e@(TVar n) = maybe e id (lookupAFCSubst sub n)
subst sub (TCons t tys) = TCons t (map (subst sub) tys)
subst sub (FuncType a b) = FuncType (subst sub a) (subst sub b)
subst sub (ForallType ns t) = ForallType ns (subst sub t)
......@@ -18,9 +18,9 @@ module FlatCurry.Annotated.Types
, module FlatCurry.Types
) where
import FlatCurry.Types ( QName, VarIndex, Visibility (..), TVarIndex
, TypeDecl (..), OpDecl (..), Fixity (..)
, TypeExpr (..), ConsDecl (..)
import FlatCurry.Types ( QName, VarIndex, Visibility (..), TVarIndex, TVarWithKind
, TypeDecl (..), Kind(..), OpDecl (..), Fixity (..)
, TypeExpr (..), ConsDecl (..), NewConsDecl (..)
, Literal (..), CombType (..), CaseType (..)
)
......@@ -62,4 +62,3 @@ data APattern a
= APattern a (QName, a) [(VarIndex, a)] --- constructor pattern
| ALPattern a Literal --- literal pattern
deriving (Eq, Ord, Read, Show)
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment