Add version 0.0.1 of ICurry

LICENSE

+Copyright (c) 2017, Bastian Kirchmayr
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+
+3. Neither the names of the copyright holders nor the names of its
+   contributors may be used to endorse or promote products derived from
+   this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md

+ICurry
+======

package.json

+{
+  "name": "icurry",
+  "version": "0.0.1",
+  "author": "Bastian Kirchmayr <bki@informatik.uni-kiel.de>",
+  "maintainer": "Jasper Paul Sikorra <jsi@informatik.uni-kiel.de>",
+  "synopsis": "Intermediate language for the translation of Curry to imperative languages",
+  "category": [ "Metaprogramming" ],
+  "license": "BSD-3-Clause",
+  "licenseFile": "LICENSE",
+  "dependencies": {
+  }
+}

src/ICurry/GenICurry.curry

+--- Transforms an Annotated FlatCurry program into ICurry
+module ICurry.GenICurry where
+
+import FlatCurry.Annotated.Types
+import FlatCurry.Annotated.Goodies
+  ( allVarsInRule, annExpr, isCombTypeFuncCall, isCombTypeFuncPartCall
+  , isTypeSyn, trTypeExpr, updTVars)
+import FlatCurry.Types             (Pattern(..))
+
+import Rewriting.Term              (Term(..))
+import Rewriting.Unification       (unify)
+
+import FiniteMap
+  (FM, addListToFM, emptyFM, fmToList, lookupFM, plusFM)
+import List                        (nub, maximum, sortBy)
+import Maybe                       ((>>-), fromJust, fromMaybe)
+import SetRBT
+  (SetRBT, deleteRBT, elemRBT, emptySetRBT, insertRBT, setRBT2list, unionRBT)
+
+import ICurry.Types
+import ICurry.ISState
+
+--- Main transformation function
+genIProg :: AProg TypeExpr -> IS IProg
+genIProg (AProg mod is tys fns _) =
+    -- generator functions for each data type
+    mapES genGenFunc dTys  >+= \gFuncs  ->
+    -- regular functions
+    mapES genFuncs fns     >+= \fFuncss ->
+    returnES $ IProg mod is iDatas (gFuncs ++ concat fFuncss)
+  where
+    dTys   = filter (not . isTypeSyn) tys
+    iDatas = map buildIData dTys
+
+--- Transforms data types into IData's
+buildIData :: TypeDecl -> IData
+buildIData (Type (_, name) _ _ conss) = IData dName $ map buildICons conss
+  where
+    dName = buildName DataId name
+buildIData (TypeSyn _ _ _ _)          = error "Cam.GenICurry.buildIData: unreachable"
+
+buildICons :: ConsDecl -> ICons
+buildICons (Cons (_, name) arity _ _) = ICons (buildName ConsId name) arity name
+
+--- Builds a generator function for each data type
+genGenFunc :: TypeDecl -> IS IFunc
+genGenFunc (Type (_, name) _ ps conss) =
+    -- ids of type variables are reused as variable ids
+    setGenVars (zip ps ps) >+
+    unzipMapES genGenCons conss >+= \(exprs, envs) ->
+    let (dem, _)              = combineEnvs envs
+        arity                 = length ps
+        fName                 = buildName GenId name
+        f v | v `elemRBT` dem = IParam v
+            | otherwise       = IAnonParam         in
+    -- (IFree exprs) is a disjunction of all constructors
+    returnES $ IFunc fName arity Private Nothing (IRule (map f ps) [] (IFree exprs))
+genGenFunc (TypeSyn _ _ _ _)          = error "Cam.GenICurry.genGenFunc: unreachable"
+
+--- Builds an expression that contains a constructor with generator calls as its
+--- arguments
+genGenCons :: ConsDecl -> VE
+genGenCons (Cons (mod, name) _ _ tys) =
+    unzipMapES (genIGen IGen) tys >+= \(iExprs, envs) ->
+    returnVE (IComb ConsCall (mod, buildName ConsId name) iExprs) $ combineEnvs envs
+
+--- Splits an Annotated FlatCurry function into several ICurry functions
+genFuncs :: AFuncDecl TypeExpr -> IS [IFunc]
+genFuncs (AFunc (_, name) arity v ty rule) =
+    newFunc name nextId                  >+
+    checkRule name rule                  >+
+    genIRules arity v (typeArgs ty) rule >+
+    getRules                             >+= \rs ->
+    returnES $ map (\(n, v, r) -> IFunc n arity v (Just ty) r) rs
+  where
+    nextId = minFreeId (allVarsInRule rule)
+
+--- Adds special main function if necessary
+checkRule :: String -> ARule TypeExpr -> IS ()
+checkRule name r | name == "*" = case r of
+    ARule _ [(p1, _),(p2, _)] (ACase _ _ (AVar _ p3) [b1]) | p1 == p3 -> case b1 of
+      ABranch (ALPattern _ (Intc 6)) (ACase _ _ (AVar _ p4) [b2]) | p2 == p4 -> case b2 of
+        ABranch (ALPattern _ (Intc 9)) (ALit _ (Intc 42))
+          -> addRule_ (const "x_main") Private (IRule [] [] (ILit (Intc 42)))
+        _ -> returnES ()
+      _                                                               -> returnES ()
+    _                                                 -> returnES ()
+                 | otherwise = returnES ()
+
+--- Builds IRules from an Annotated FlatCurry rule and adds them to the state
+genIRules :: Arity -> Visibility -> [TVarIndex] -> ARule TypeExpr -> IS ()
+genIRules arity v _     (AExternal _ str) =
+    addRule_ (buildName FuncId) v $ IExternal arity str
+genIRules _ v     tVars (ARule _ ps expr) =
+    mapES (const newVarId) tVars >+= \genPs               ->
+    -- generator parameter for each type parameter
+    setGenVars (zip tVars genPs) >+
+    genIExpr expr                >+= \(iExpr, (dem, def)) ->
+    getTopRuleQName              >+= \top                 ->
+    let ls    = buildLocals def
+        ps'   = map (buildIParam dem) $ genPs ++ map fst ps in
+     if top /= Nothing && top == combQName iExpr
+     -- if the top rule is simply a function call not a case expression,
+     -- it can be renamed and used as the public function
+     -- so we don't generate too many extra functions
+     then modifyTopRule (\name (_, _, r) -> (buildName FuncId name, v, f ps' ls r))
+     else addRule_ (buildName FuncId) v $ IRule ps' ls iExpr
+  where
+    combQName e = case e of
+      IComb _ qName _ -> Just qName
+      _               -> Nothing
+
+    f ps' ls r = addLocals ls (setParams ps' r)
+
+--- If a variable is not used it is made anonymous
+buildIParam :: DemandedEnv -> VarIndex -> IParam
+buildIParam dem v | v `elemRBT` dem = IParam v
+                  | otherwise       = IAnonParam
+
+--- Extracts locals from environment
+buildLocals :: DefinedEnv -> [ILocal]
+buildLocals def = map (uncurry ILocal) $ fmToList def
+
+--- Builds an ICurry expression from an Annotated FlatCurry expression, possibly
+--- adding new helper functions
+genIExpr :: AExpr TypeExpr -> VE
+genIExpr (AVar _ v)           = returnVE (IVar v) $ demand v emptyEnv
+genIExpr (ALit _ lit)         = returnVE (ILit lit) emptyEnv
+genIExpr (AComb _ t aName ps) =
+    unzipMapES genIExpr ps  >+= \(iPs, envs)    ->
+    -- adds generator parameters to the function
+    genCombGens t aName     >+= \(pGens, envs') ->
+    -- adds a unique parameter for calls to `global`
+    genGlobalId (fst aName) >+= \globalId       ->
+    let ps' = pGens ++ globalId ++ iPs in
+    returnVE (buildIComb t qName ps') $ combineEnvs (envs' ++ envs)
+  where
+    (mod, name) = fst aName
+    qName       = (mod, buildFuncName t name)
+genIExpr (ALet _ ls expr)     =
+    unzipMapES genLs ls >+= \ve           ->
+    genIExpr expr       >+= \(iExpr, env) ->
+    -- let's are saved in VE since they can only occur at the top of functions
+    -- or branches in ICurry
+    returnVE iExpr $ combineLocalEnvs ve env
+genIExpr (AFree _ fs expr)    =
+    unzipMapES genFree fs >+= \ve      ->
+    genIExpr expr    >+= \(iExpr, env) ->
+    returnVE iExpr $ combineLocalEnvs ve env
+genIExpr (AOr _ expr1 expr2)  =
+    genIExpr expr1 >+= \(iExpr1, env1) ->
+    genIExpr expr2 >+= \(iExpr2, env2) ->
+    let env  = combineEnvs [env1, env2]
+        ors1 = unpackIOr iExpr1
+        ors2 = unpackIOr iExpr2 in
+     returnVE (IOr $ ors1 ++ ors2) env
+genIExpr (ACase _ _ expr bs)  =
+    -- a new function is generated for each case
+    newFuncId                                   >+= \fId                   ->
+    newVarId                                    >+= \newCExprId            ->
+    getFuncName                                 >+= \name                  ->
+    genIExpr expr                               >+= \(iExpr, (demE, defE)) ->
+    unzipMapES genIBranch bs                    >+= \(iBs, demBs)          ->
+        -- VE information is combined from all branches
+    let demB     = combineDemanded demBs
+        dem'     = combineDemanded [demB, demE]
+        demBList = setRBT2list (demand' cExprId demB)
+        demList' = setRBT2list dem'
+        pExprs   = map IVar demList'
+        -- if the expression being `case'd on` is not a variable, create a new
+        -- locale one
+        cExprId  = fromMaybe newCExprId (varFromIExpr iExpr)
+        cExprLoc = if cExprId == newCExprId then [ILocal cExprId iExpr] else []
+        ls'      = cExprLoc ++ buildLocals defE
+        cName    = buildName (FuncHnfId fId) name
+        l        = buildLitTemplate (annExpr expr)
+        iRule    = ICase cName params ls' demBList cExprId l iBs
+        params   = map IParam demList'                                     in
+     addRule (buildName (FuncCaseId fId)) Private iRule >+= \qName         ->
+     returnVE (IComb FuncCall qName pExprs) (dem', emptyFM (<))
+genIExpr (ATyped _ expr _)    = genIExpr expr
+
+--- In case of a call to `global` add unique id as an additional parameter to
+--- distinguish between calls
+genGlobalId :: QName -> IS [IExpr]
+genGlobalId qName | qName == ("Global", "global") = f <$> nextGlobalId
+                  | otherwise                     = returnES []
+  where
+    f Nothing          = []
+    f (Just (mod, id)) = [IString mod, ILit (Intc id)]
+
+--- Returns the variable id if the expression is a straight variable
+varFromIExpr :: IExpr -> Maybe VarIndex
+varFromIExpr expr = case expr of
+  IVar v -> Just v
+  _      -> Nothing
+
+--- Returns a literal (with an arbitrary value) if the input type is a literal
+buildLitTemplate :: TypeExpr -> Maybe Literal
+buildLitTemplate (TVar _)        = error "GenICurry.buildLitTemplate: unreachable"
+buildLitTemplate (FuncType _ _)  = Nothing
+buildLitTemplate (TCons qName _) = case qName of
+  ("Prelude", "Int")   -> Just (Intc 42)
+  ("Prelude", "Float") -> Just (Floatc 42)
+  ("Prelude", "Char")  -> Just (Charc '*')
+  _                    -> Nothing
+
+--- Returns a prefixed function/constructor name for a CombType
+buildFuncName :: CombType -> String -> String
+buildFuncName t name = if isCombTypeAnyFuncCall t
+                       then buildName FuncId name
+                       else buildName ConsId name
+
+--- Returns an IExpr for a call, replacing lists with their IExpr equivalent IList
+buildIComb :: CombType -> QName -> [IExpr] -> IExpr
+buildIComb t qName ps = case t of
+  ConsCall -> buildICombCons qName ps
+  _        -> IComb t qName ps
+
+--- Returns an IExpr for a constructor call, replacing lists with their IExpr
+--- equivalent IList
+buildICombCons :: QName -> [IExpr] -> IExpr
+buildICombCons qName ps = case qName of
+    ("Prelude", "c_[]") -> IList []
+    ("Prelude", "c_:")  -> buildIList qName ps
+    _                 -> IComb ConsCall qName ps
+
+--- 'Compresses' an IExpr list by combining "x : IList xs" to "IList (x:xs)" or
+--- "IString xs" if xs are characters
+buildIList :: QName -> [IExpr] -> IExpr
+buildIList qName ps = case ps of
+    [ILit (Charc c), IList []]  -> IString [c]
+    [ILit (Charc c), IString s] -> IString (c:s)
+    [x             , IList xs]  -> IList (x:xs)
+    _                           -> IComb ConsCall qName ps
+
+--- Returns a list of generator IExpr's needed for a function call and their VarEnv's
+genCombGens :: CombType -> (QName, TypeExpr) -> IS ([IExpr], [VarEnv])
+genCombGens t (qName, ty) = if isCombTypeAnyFuncCall t
+                            then getFuncType qName >+=
+                                 inferCombGens ty  >+=
+                                 unzipMapES (genIGen IVar)
+                            else returnES ([], [])
+
+--- Returns the list of type variable expressions needed to call a function
+inferCombGens :: TypeExpr -> TypeExpr -> IS [TypeExpr]
+inferCombGens callTy fnTy = case unify eqs of
+    Left err    -> failES $ show err
+    Right subst -> returnES $ map (toTypeExpr . fromJust . lookupFM subst) tArgs
+  where
+    minId = minFreeId (typeArgs callTy)
+    fnTy' = updTVars (TVar . (minId+)) fnTy
+    eqs   = [(fromTypeExpr fnTy', fromTypeExpr callTy)]
+    tArgs = typeArgs fnTy'
+
+--- Transforms a type expression into the IExpr representing its generator call.
+--- The function parameter indicates whether a variable should be an IVar or IGen.
+genIGen :: (VarIndex -> IExpr) -> TypeExpr -> VE
+genIGen genV (TVar tVar)    =
+    getGenVar tVar >+= \var ->
+      case var of
+        Nothing -> returnVE (INoGen "Unknown") emptyEnv
+        Just v  -> returnVE (genV v) $ demand v emptyEnv
+genIGen _ (FuncType _ _)    = returnVE (INoGen "Function") emptyEnv
+genIGen _ (TCons tName tys)
+  | mod == "Prelude" && name `elem` lits = returnVE (INoGen name) emptyEnv
+  | otherwise                            =
+    unzipMapES (genIGen IVar) tys >+= \(iExprs, envs) ->
+    returnVE (IComb FuncCall qName iExprs) $ combineEnvs envs
+  where
+    (mod, name) = tName
+    qName       = (mod, buildName GenId name)
+    lits        = ["Int", "Float", "Char", "IO"]
+
+genLs :: ((VarIndex, TypeExpr), AExpr TypeExpr) -> IS ((VarIndex, IExpr), VarEnv)
+genLs ((v, _), expr) = genIExpr expr >+= \(iExpr, env) ->
+                       returnES ((v, iExpr), env)
+
+genFree :: (VarIndex, TypeExpr) -> IS ((VarIndex, IExpr), VarEnv)
+genFree (v, ty) = genIGen IGen ty >+= \(iExpr, env) ->
+                  returnES ((v, iExpr), env)
+
+unpackIOr :: IExpr -> [IExpr]
+unpackIOr expr = case expr of
+  IOr l -> l
+  _     -> [expr]
+
+--- Transforms an ABranchExpr into an IBranch
+genIBranch :: ABranchExpr TypeExpr -> IS (IBranch, DemandedEnv)
+genIBranch (ABranch p expr) =
+    genIExpr expr >+= \(iExpr, (dem, def)) ->
+    let (p', vars) = buildIPattern dem p   in
+    returnES (IBranch p' (buildLocals def) iExpr, foldr deleteRBT dem vars)
+
+--- Transforms an APattern into an IPattern
+buildIPattern :: DemandedEnv -> APattern a -> (IPattern, [VarIndex])
+buildIPattern dem (APattern _ ((mod, name), _) ps) = (IPattern qName ps', vars)
+  where
+    qName = (mod, buildName ConsId name)
+    ps'   = map f ps
+    vars  = map (\(IParam v) -> v) $ filter (/=IAnonParam) ps'
+
+    f (v, _) | v `elemRBT` dem = IParam v
+             | otherwise       = IAnonParam
+buildIPattern _ (ALPattern _ lit)                  = (ILPattern lit, [])
+
+------------------------------------------
+
+--- helper functions
+
+unzipMapES :: (a -> ES e s (b, c)) -> [a] -> ES e s ([b], [c])
+unzipMapES f l = unzip <$> mapES f l
+
+isCombTypeAnyFuncCall :: CombType -> Bool
+isCombTypeAnyFuncCall t = isCombTypeFuncCall t || isCombTypeFuncPartCall t
+
+setParams :: [IParam] -> IRule -> IRule
+setParams _  (IExternal _ _)               = error $ "Cam.GenICurry.setParams: "
+                                                  ++ "external function"
+setParams ps (IRule _ ls expr)             = IRule ps ls expr
+setParams ps (ICase cName _ ls ps' e l bs) = ICase cName ps ls ps' e l bs
+
+addLocals :: [ILocal] -> IRule -> IRule
+addLocals _  (IExternal _ _)                 = error $ "Cam.GenICurry.addLocals: "
+                                                    ++ "external function"
+addLocals ls (IRule ps ls' expr)             = IRule ps (ls'++ls) expr
+addLocals ls (ICase cName ps ls' ps' e l bs) = ICase cName ps (ls'++ls) ps' e l bs
+
+typeArgs :: TypeExpr -> [TVarIndex]
+typeArgs = sortBy (<) . nub . trTypeExpr (:[]) (const concat) (++)
+
+minFreeId :: [Int] -> Int
+minFreeId []      = 0
+minFreeId l@(_:_) = maximum l + 1
+
+------------------------------------------
+
+type VE          = IS (IExpr, VarEnv)
+
+--- Contains all variables that are used by an associated expression, but not
+--- defined by it
+type DemandedEnv = SetRBT VarIndex
+
+--- Contains all variable definitions introduced by an associated expression
+type DefinedEnv  = FM VarIndex IExpr
+type VarEnv      = (DemandedEnv, DefinedEnv)
+
+returnVE :: IExpr -> VarEnv -> VE
+returnVE expr env = returnES (expr, env)
+
+emptyEnv :: VarEnv
+emptyEnv = (emptySetRBT (<), emptyFM (<))
+
+demand :: VarIndex -> VarEnv -> VarEnv
+demand v (dem, def) = (insertRBT v dem, def)
+
+demand' :: VarIndex -> DemandedEnv -> DemandedEnv
+demand' v dem = insertRBT v dem
+
+combineDemanded :: [DemandedEnv] -> DemandedEnv
+combineDemanded = foldr unionRBT (emptySetRBT (<))
+
+combineDefined :: [DefinedEnv] -> DefinedEnv
+combineDefined = foldr plusFM (emptyFM (<))
+
+combineEnvs :: [VarEnv] -> VarEnv
+combineEnvs envs = (combineDemanded dems, combineDefined defs)
+  where
+    (dems, defs) = unzip envs
+
+combineLocalEnvs :: ([(VarIndex, IExpr)], [VarEnv]) -> VarEnv -> VarEnv
+combineLocalEnvs (iLs, envs) env = (dem', def')
+  where
+    (dem, def) = combineEnvs (env:envs)
+    dem'       = foldl (\d (v, _) -> deleteRBT v d) dem iLs
+    def'       = addListToFM def iLs
+
+------------------------------------------
+
+--- Types used to identify the prefix of a prefixed id
+
+data IdType = DataId | ConsId | FuncId | FuncCaseId Int | FuncHnfId Int | GenId
+
+--- Prefixes a name
+
+buildName :: IdType -> String -> String
+buildName id name = pre ++ name
+  where
+    pre = case id of
+            DataId       -> "d_"
+            ConsId       -> "c_"
+            FuncId       -> "f_"
+            FuncCaseId n -> 'f':show n ++ "_"
+            FuncHnfId n  -> 'h':show n ++ "_"
+            GenId        -> "g_"
+
+------------------------------------------
+-- from FlatCurry/Annotated/TypeInference.curry
+fromTypeExpr :: TypeExpr -> Term String
+fromTypeExpr (TVar       n) = TermVar n
+fromTypeExpr (TCons   t vs) = TermCons (fromQName t) (map fromTypeExpr vs)
+fromTypeExpr (FuncType a b) = TermCons "->" [fromTypeExpr a, fromTypeExpr b]
+
+toTypeExpr :: Term String -> TypeExpr
+toTypeExpr (TermVar     n) = TVar n
+toTypeExpr (TermCons t vs)
+    | t == "->" = FuncType (toTypeExpr (vs !! 0)) (toTypeExpr (vs !! 1))
+    | otherwise = TCons (toQName t) (map toTypeExpr vs)
+
+fromQName :: QName -> String
+fromQName (mod, typ) = mod ++ ";" ++ typ
+
+toQName :: String -> QName
+toQName str = (fst split, snd split)
+  where split = splitFirst str ';'
+
+splitFirst :: [a] -> a -> ([a], [a])
+splitFirst []     _ = ([], [])
+splitFirst (x:xs) c
+  | x == c    = ([], xs)
+  | otherwise = (x : fst rest, snd rest)
+    where rest = splitFirst xs c
+

src/ICurry/ISState.curry

+--- Helper module for GenICurry provides an ErrorState with some state
+--- information and functions to use it
+
+module ICurry.ISState
+  ( module ErrorState
+  , module ICurry.ISState
+  , liftE, liftM, whenES
+  ) where
+
+import FlatCurry.Types (QName, TVarIndex, TypeExpr, VarIndex, Visibility)
+
+import ErrorState
+import FiniteMap       (FM, emptyFM, listToFM, lookupFM)
+import Maybe           ((>>-))
+
+import ICurry.Types    (IRule)
+import ICurry.Utils    (liftE, liftM, whenES)
+
+--- A State holds the following information:
+---   - modName: The name of the module
+---   - curNextGlobalId: Used to implement the Global module, each call of
+---     `global` gets its own (module-)unique id
+---   - progEnv: Type information for the module as provided by FlatCurry.Annotated
+---   - curFuncName: The name of the function being currently processed
+---   - curNextVarId: Provides fresh variable ids, holds the next free id
+---   - curNextFuncId Provides fresh function ids, holds the next free id
+---   - curGenVars: Holds the generator parameters for the current function
+---   - curRules: All the rules generated for the current functino so far
+---     (name, visibility, rule)
+data ISState = ISState
+                 { modName          :: String
+                 , curNextGlobalId  :: Maybe Int
+                 , progEnv          :: FM QName TypeExpr
+                 , curFuncName      :: Maybe String
+                 , curNextVarId     :: VarIndex
+                 , curNextFuncId    :: Int
+                 , curGenVars       :: FM TVarIndex VarIndex
+                 , curRules         :: [(String, Visibility, IRule)]
+                 }
+
+type IS a = ES String ISState a
+
+--- Initializes an ISState, enableGlobal determines whether calls to `global`
+--- should get a unique id
+initIS :: Bool -> String -> FM QName TypeExpr -> ISState
+initIS enableGlobal mod pEnv = ISState
+    { modName         = mod
+    , curNextGlobalId = if enableGlobal then Just 1 else Nothing
+    , progEnv         = pEnv
+    , curFuncName     = Nothing
+    , curNextVarId    = 0
+    , curNextFuncId   = 0
+    , curGenVars      = emptyFM (<)
+    , curRules        = []
+    }
+
+--- Returns the name of the module
+getModule :: IS String
+getModule = modName <$> gets
+
+--- Returns the name of the current module and a fresh global id if global ids
+--- are enabled
+nextGlobalId :: IS (Maybe (String, Int))
+nextGlobalId =
+    curNextGlobalId <$> gets >+= \mGId ->
+    case mGId of
+      Nothing  -> returnES Nothing
+      Just gId ->
+        getModule                                           >+= \mod ->
+        modify (\s -> s { curNextGlobalId = Just (gId+1) }) >+
+        returnES (Just (mod, gId))
+
+--- Returns the type of a function
+getFuncType :: QName -> IS TypeExpr
+getFuncType qName =
+    progEnv <$> gets >+= \env ->
+    case lookupFM env qName of
+      Nothing -> error $ "ICurry.ISState.getFuncType: not found: " ++ show qName
+      Just ty -> returnES ty
+
+--- Sets a new current function with a new name and id
+newFunc :: String -> VarIndex -> IS ()
+newFunc name nextId = modify (\s -> s
+    { curFuncName   = Just name
+    , curNextVarId  = nextId
+    , curNextFuncId = 0
+    , curGenVars    = emptyFM (<)
+    , curRules      = []
+    })
+
+--- Returns the name of the current function
+getFuncName :: IS String
+getFuncName =
+    curFuncName <$> gets >+= \mName ->
+    case mName of
+      Nothing   -> error "ICurry.IS.State.getFuncName: no func name set"
+      Just name -> returnES name
+
+--- Returns a fresh variable id
+newVarId :: IS VarIndex
+newVarId =
+    curNextVarId <$> gets                          >+= \newVar ->
+    modify (\s -> s { curNextVarId = newVar + 1 }) >+
+    returnES newVar
+
+--- Returns a fresh function id
+newFuncId :: IS Int
+newFuncId =
+    curNextFuncId <$> gets                         >+= \newId ->
+    modify (\s -> s { curNextFuncId = newId + 1 }) >+
+    returnES newId
+
+--- Sets the generator parameters of the current function
+setGenVars :: [(TVarIndex, VarIndex)] -> IS ()
+setGenVars vars = modify (\s -> s { curGenVars = listToFM (<) vars })
+
+--- Returns the generator parameter for a type variable
+getGenVar :: TVarIndex -> IS (Maybe VarIndex)
+getGenVar tVar = flip lookupFM tVar . curGenVars <$> gets
+
+--- Adds a rule to the current function
+--- f builds the name for the rule using the functions original name
+--- Returns the QName of the new rule
+addRule :: (String -> String) -> Visibility -> IRule -> IS QName
+addRule f v rule =
+    f <$> getFuncName                                         >+= \name ->
+    getModule                                                 >+= \mod  ->
+    modify (\s -> s { curRules = (name, v, rule) : curRules s }) >+
+    returnES (mod, name)
+
+--- Adds a rule to the current function
+--- f builds the name for the rule using the functions original name
+addRule_ :: (String -> String) -> Visibility -> IRule -> IS ()
+addRule_ f v rule = addRule f v rule >+ returnES ()
+
+--- Returns the QName of the rule last added
+getTopRuleQName :: IS (Maybe QName)
+getTopRuleQName =
+    curRules <$> gets >+= \rs ->
+    case rs of
+      []               -> returnES Nothing
+      ((name, _, _):_) -> getModule >+= \mod ->
+                          returnES $ Just (mod, name)
+
+--- Modifies the rule last added
+modifyTopRule :: (String -> (String, Visibility, IRule) -> (String, Visibility, IRule))
+              -> IS ()
+modifyTopRule f =
+    getFuncName >+= \name ->
+    modify (\s -> s { curRules = modTop name (curRules s) })
+  where
+    modTop _    []       = error "ICurry.IS.State.modifyTopRule: empty rule list"
+    modTop name (r : rs) = f name r : rs
+
+--- Returns all rules of the current function
+getRules :: IS [(String, Visibility, IRule)]
+getRules =
+    curRules <$> gets                  >+= \rs ->
+    modify (\s -> s { curRules = [] }) >+
+    returnES rs
+

src/ICurry/Pretty.curry

+--- Pretty printer for ICurry, prints a syntax based loosely based on curry syntax
+
+--- Variables in angle brackets stand for generators from parameters
+
+module ICurry.Pretty(ppIProg) where
+
+import FlatCurry.Types (Literal(..), QName, VarIndex)
+
+import Pretty
+
+import ICurry.Types
+
+ppIProg :: IProg -> Doc
+ppIProg (IProg name is ds fs) =       text "module"
+                                <+>   text name
+                                <+>   text "where"
+                                <$+$> (vsep . map ppImport) is