Merge branch 'libs_refactor'

LICENSE

-Copyright (c) 2017, Michael Hanus
+Copyright (c) 2020, Michael Hanus
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without

README.md

@@ -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.

package.json

 {
     "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"

src/FlatCurry/Annotated/Files.curry

 ------------------------------------------------------------------------------
 --- 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)
 

src/FlatCurry/Annotated/Goodies.curry

@@ -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)
-

src/FlatCurry/Annotated/Pretty.curry

@@ -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

src/FlatCurry/Annotated/TypeSubst.curry

---- ----------------------------------------------------------------------------
---- 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)

src/FlatCurry/Annotated/Types.curry

@@ -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)
-