cao-0.1.1: src/Language/CAO/Syntax/Utils.hs
{- CAO Compiler
Copyright (C) 2014 Cryptography and Information Security Group, HASLab - INESC TEC and Universidade do Minho
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>. -}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-
Module : $Header$
Description : Syntax manipulation utils.
Copyright : (C) 2014 Cryptography and Information Security Group, HASLab - INESC TEC and Universidade do Minho
License : GPL
Maintainer : Paulo Silva <paufil@di.uminho.pt>
Stability : experimental
Portability : non-portable (<reason>)
General functions for AST manipulation or query are provided.
-}
module Language.CAO.Syntax.Utils
(-- * Variable manipulation
FV ( fvs )
, BV ( bvs )
, RN ( (<|>) )
, Renamable(..)
, Subst ( subst )
, IsVar
, lvname
, lvalNames
, globals
, getVars
, getLVars
, getRVars
, sameKind
-- * Sequences
, isAscSeq
-- * AST Queries
, isSimpleLVal
, isAssignStmt
, isLit
, isIntLit
, isSimpleVDecl
, isReturn
, defVar
, getDeclVar
, isRange
, isEqNeq
, type2TyDecl
, Typeable(typeOf)
) where
import Data.IntMap ( IntMap )
import qualified Data.IntMap as IntMap
import Data.List ( foldl' )
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Set ( Set )
import qualified Data.Set as Set
import Language.CAO.Common.Literal
import Language.CAO.Common.Outputable
import Language.CAO.Common.Polynomial
import Language.CAO.Common.SrcLoc
import Language.CAO.Common.Utils ( mapSnd )
import Language.CAO.Common.Var
import Language.CAO.Index
import Language.CAO.Index.Utils
import Language.CAO.Syntax
import Language.CAO.Type
import Language.CAO.Type.Utils
type family VarOf f :: *
type instance VarOf Name = Name
type instance VarOf Var = Var
type instance VarOf (Maybe a) = VarOf a
type instance VarOf [a] = VarOf a
type instance VarOf (Located a) = VarOf a
type instance VarOf (Either a a) = VarOf a
type instance VarOf (Prog a) = a
type instance VarOf (Def a) = a
type instance VarOf (VarDecl a) = a
type instance VarOf (ConstAnn a) = a
type instance VarOf (ConstDecl a) = a
type instance VarOf (Fun a) = a
type instance VarOf (TyDef a) = a
type instance VarOf (TyDecl a) = a
type instance VarOf (Expr a) = a
type instance VarOf (TExpr a) = a
type instance VarOf (BinOp a) = a
type instance VarOf (Stmt a) = a
type instance VarOf (Arg a) = a
type instance VarOf (Mod a) = a
type instance VarOf (Pol a) = a
type instance VarOf (Mon a) = a
type instance VarOf (MCoef a) = a
type instance VarOf (MBase a) = a
type instance VarOf (APat a) = a
type instance VarOf (RowAPat a) = a
type instance VarOf (Literal a) = a
type instance VarOf (LVal a) = a
type instance VarOf (Type a) = a
type instance VarOf (Class a) = a
type instance VarOf (ICond a) = a
type instance VarOf (IExpr a) = a
type family SubstOf f :: *
type instance SubstOf Name = Name
type instance SubstOf Var = Var
type instance SubstOf (Maybe a) = SubstOf a
type instance SubstOf [a] = SubstOf a
type instance SubstOf (Located a) = SubstOf a
type instance SubstOf (Prog a) = Expr a
type instance SubstOf (Def a) = Expr a
type instance SubstOf (VarDecl a) = Expr a
type instance SubstOf (ConstDecl a) = Expr a
type instance SubstOf (Fun a) = Expr a
type instance SubstOf (TyDef a) = Expr a
type instance SubstOf (TyDecl a) = Expr a
type instance SubstOf (Expr a) = Expr a
type instance SubstOf (TExpr a) = Expr a
type instance SubstOf (BinOp a) = Expr a
type instance SubstOf (Stmt a) = Expr a
type instance SubstOf (Arg a) = Expr a
type instance SubstOf (Mod a) = Expr a
type instance SubstOf (Pol a) = IExpr a
type instance SubstOf (Mon a) = IExpr a
type instance SubstOf (MCoef a) = IExpr a
type instance SubstOf (MBase a) = Expr a
type instance SubstOf (APat a) = Expr a
type instance SubstOf (RowAPat a) = Expr a
type instance SubstOf (Literal a) = Expr a
type instance SubstOf (LVal a) = Expr a
type instance SubstOf (Type a) = IExpr a
type instance SubstOf (Class a) = Expr a
type instance SubstOf (ICond a) = IExpr a
type instance SubstOf (IExpr a) = IExpr a
class (FV id, BV id, Ord id, PP id, RN id) => IsVar id where
instance IsVar Name where
instance IsVar Var where
--------------------------------------------------------------------------------
-- Free variables
--------------------------------------------------------------------------------
-- | Free variables
class FV f where
fvs :: (Ord b, VarOf f ~ b) => f -> Set b
fvsLst :: (Ord b, VarOf f ~ b) => [f] -> Set b
fvsLst = Set.unions . map fvs
instance FV a => FV (Maybe a) where
fvs Nothing = Set.empty
fvs (Just a) = fvs a
instance FV a => FV (Located a) where
fvs (L _ a) = fvs a
instance FV a => FV [a] where
fvs = fvsLst
instance (FV a, a ~ b) => FV (Either a b) where
fvs (Left l) = fvs l
fvs (Right r) = fvs r
instance FV Name where
fvs = Set.singleton
instance FV Var where
fvs = Set.singleton
instance (IsVar a, a ~ VarOf a) => FV (Def a) where
fvs (VarDef vd) = fvs vd
fvs (FunDef fd) = fvs fd
fvs (TyDef td) = fvs td
fvs (ConstDef cd) = fvs cd
instance (IsVar a, a ~ VarOf a) => FV (VarDecl a) where
fvs (VarD v td me) = (fvs td `Set.union` fvs me) Set.\\ fvs v
fvs (MultiD vs td) = fvs td Set.\\ fvs vs
fvs (ContD v td es) = (fvs td `Set.union` fvs es) Set.\\ fvs v
instance (IsVar a, a ~ VarOf a) => FV (ConstAnn a) where
fvs None = Set.empty
fvs (ConstInit e) = fvs e
fvs (ConstCond c) = fvs c
instance (IsVar a, a ~ VarOf a) => FV (ConstDecl a) where
fvs (ConstD v td i) = (fvs td `Set.union` fvs i) Set.\\ fvs v
fvs (MultiConstD vs td c) = (fvs td `Set.union` fvs c) Set.\\ fvs vs
instance (IsVar a, a ~ VarOf a) => FV (Fun a) where
fvs (Fun v args rt body) = (fvs body `Set.union` fvs rt)
Set.\\ (fvs v `Set.union` fvs args)
instance (IsVar a, a ~ VarOf a) => FV (Arg a) where
fvs (Arg a _) = fvs a
fvs (ArgConst a _ _) = fvs a
instance (IsVar a, a ~ VarOf a) => FV (TyDef a) where
fvs (TySynDef v td)
= fvs td Set.\\ fvs v
fvs (StructDecl v flds)
= Set.unions (map (fvs . snd) flds)
Set.\\ Set.unions (fvs v: map (fvs . fst) flds)
instance (IsVar a, a ~ VarOf a) => FV (TyDecl a) where
fvs IntD = Set.empty
fvs RIntD = Set.empty
fvs BoolD = Set.empty
fvs (BitsD _ e) = fvs e
fvs (ModD m) = fvs m
fvs (VectorD e td) = fvs e `Set.union` fvs td
fvs (MatrixD e1 e2 td) = fvs e1 `Set.union` fvs e2 `Set.union` fvs td
fvs (TySynD v) = fvs v
instance (IsVar a, a ~ VarOf a) => FV (Mod a) where
fvs (ModNum e) = fvs e
fvs (ModPol td ti pol) = (fvs td `Set.union` fvs pol) Set.\\ fvs ti
instance (IsVar a, a ~ VarOf a) => FV (TExpr a) where
fvs (TyE _ e) = fvs e
instance (IsVar a, a ~ VarOf a) => FV (Expr a) where
fvs (Var v) = fvs v
fvs (Lit l) = fvs l
fvs (FunCall v args) = fvs v `Set.union` fvs args
fvs (StructProj e fi) = fvs e `Set.union` fvs fi
fvs (UnaryOp _ e) = fvs e
fvs (BinaryOp _ e1 e2) = fvs e1 `Set.union` fvs e2
fvs (Access e1 pat) = fvs e1 `Set.union` fvs pat
fvs (Cast _ td e) = fvs td `Set.union` fvs e
instance (IsVar a, a ~ VarOf a) => FV (BinOp a) where
fvs _ = Set.empty
instance (IsVar a, a ~ VarOf a) => FV (Literal a) where
fvs (PLit p) = fvs p
fvs _ = Set.empty
instance (IsVar a, a ~ VarOf a) => FV (APat a) where
fvs (VectP rp) = fvs rp
fvs (MatP rp cp) = fvs rp `Set.union` fvs cp
instance (IsVar a, a ~ VarOf a) => FV (RowAPat a) where
fvs (CElem e) = fvs e
fvs (CRange e1 e2) = fvs e1 `Set.union` fvs e2
instance (IsVar a, a ~ VarOf a) => FV (Stmt a) where
fvs (VDecl vd) = fvs vd
fvs (CDecl cd) = fvs cd
fvs (Assign lvs es) = fvs lvs `Set.union` fvs es
fvs (FCallS n es) = fvs n `Set.union` fvs es
fvs (Ret e) = fvs e
fvs (Ite i t e) = fvs i `Set.union` fvs t `Set.union` fvs e
fvs (Seq (SeqIter v s e b _) ss) =
(fvs s `Set.union` fvs e `Set.union` fvs b `Set.union` fvs ss)
Set.\\ fvs v
fvs (While e ss) = fvs e `Set.union` fvs ss
fvs (Nop _) = Set.empty
fvsLst [] = Set.empty
fvsLst (VDecl vd:ss) = fvs ss Set.\\ fvs vd
fvsLst (s:ss) = fvs s `Set.union` fvs ss
instance (IsVar a, a ~ VarOf a) => FV (LVal a) where
fvs (LVVar v) = fvs v
fvs (LVStruct lv fi) = fvs lv `Set.union` fvs fi
fvs (LVCont _ lv p) = fvs lv `Set.union` fvs p
instance (IsVar a, a ~ VarOf a) => FV (Pol a) where
fvs (Pol ms) = fvs ms
instance (IsVar a, a ~ VarOf a) => FV (Mon a) where
fvs (Mon c b) = fvs c `Set.union` fvs b
instance (IsVar a, a ~ VarOf a) => FV (MCoef a) where
fvs (CoefI _) = Set.empty
fvs (CoefP p) = fvs p
instance (IsVar a, a ~ VarOf a) => FV (MBase a) where
fvs EZero = Set.empty
fvs (MExpI n _) = fvs n
instance (IsVar a, a ~ VarOf a) => FV (Type a) where
fvs Int = Set.empty
fvs RInt = Set.empty
fvs Bool = Set.empty
fvs Bullet = Set.empty
fvs (Bits _ e) = fvs e
fvs (Indet t) = fvs t
fvs (Tuple ts) = fvs ts
fvs (Vector e t) = fvs e `Set.union` fvs t
fvs (TySyn v t) = fvs v `Set.union` fvs t
fvs (SField v t) = fvs v `Set.union` fvs t
fvs (Mod mty e p) = Set.unions [fvs mty, fvs e, fvs p]
fvs (Matrix e1 e2 t) = Set.unions [fvs e1, fvs e2, fvs t]
fvs (FuncSig ts t c) = Set.unions [fvs ts, fvs t, fvs c]
fvs (Struct v fs) = Set.unions [fvs v, fvs (map fst fs),
fvs (map snd fs)]
fvs (Index v mc t) = Set.unions [fvs v, fvs mc, fvs t]
fvs (TyVar _) = Set.empty
fvs (IntVar _) = Set.empty
fvs (ModVar _) = Set.empty
instance (IsVar a, a ~ VarOf a) => FV (IExpr a) where
fvs (IInt _) = Set.empty
fvs (IInd v) = Set.singleton v
fvs (ISum es) = fvs es
fvs (IArith _ e1 e2) = fvs e1 `Set.union` fvs e2
fvs (ISym e) = fvs e
instance (IsVar a, a ~ VarOf a) => FV (ICond a) where
fvs (IBool _) = Set.empty
fvs (IBInd v) = Set.singleton v
fvs (INot c) = fvs c
fvs (IAnd cs) = fvs cs
fvs (IBoolOp _ e1 e2) = fvs e1 `Set.union` fvs e2
fvs (ILeq e) = fvs e
fvs (IEq e) = fvs e
instance (IsVar a, a ~ VarOf a) => FV (Class a) where
fvs _ = Set.empty
--------------------------------------------------------------------------------
-- Bound variables (defs, args, etc ...)
-- * The bound variables of fun/proc definition are it's local variables
--------------------------------------------------------------------------------
-- | Bound variables (defs, args, etc ...)
-- The bound variables of function/procedure definition are its local variables.
class BV f where
bvs :: (Ord b, VarOf f ~ b) => f -> Set b
instance BV a => BV (Maybe a) where
bvs Nothing = Set.empty
bvs (Just a) = bvs a
instance BV a => BV (Located a) where
bvs (L _ a) = bvs a
instance BV a => BV [a] where
bvs = Set.unions . map bvs
globals :: Prog Var -> Set Var
globals = Set.filter isGlobal . bvs
instance (IsVar a, a ~ VarOf a) => BV (Prog a) where
bvs (Prog defs ip) = bvs defs `Set.union` maybe Set.empty bvs ip
instance (IsVar a, a ~ VarOf a) => BV (Def a) where
bvs (VarDef vd) = bvs vd
bvs (FunDef fd) = bvs fd
bvs (TyDef td) = bvs td
bvs (ConstDef cd) = bvs cd
instance (IsVar a, a ~ VarOf a) => BV (VarDecl a) where
bvs (VarD v _ _) = fvs v
bvs (MultiD vs _) = fvs vs
bvs (ContD v _ _) = fvs v
instance (IsVar a, a ~ VarOf a) => BV (ConstDecl a) where
bvs (ConstD v _ _) = fvs v
bvs (MultiConstD vs _ _) = fvs vs
instance (IsVar a, a ~ VarOf a) => BV (Fun a) where
bvs (Fun v args _ body) = bvs body `Set.union` fvs v `Set.union` fvs args
instance (IsVar a, a ~ VarOf a) => BV (TyDef a) where
bvs (TySynDef v _)
= fvs v
bvs (StructDecl v flds)
= Set.unions $ fvs v : map (fvs . fst) flds
instance (IsVar a, a ~ VarOf a) => BV (Mod a) where
bvs (ModNum _) = Set.empty
bvs (ModPol _ ti _) = fvs ti
instance (IsVar a, a ~ VarOf a) => BV (Stmt a) where
bvs (VDecl vd) = bvs vd
bvs (CDecl cd) = bvs cd
bvs (Ite _ t e) = bvs t `Set.union` bvs e
bvs (Seq (SeqIter v _ _ _ _) ss) = fvs v `Set.union` bvs ss
bvs (While _ ss) = bvs ss
bvs _ = Set.empty
instance BV Name where
bvs _ = Set.empty
instance BV Var where
bvs _ = Set.empty
instance (IsVar a, a ~ VarOf a) => BV (Arg a) where
bvs _ = Set.empty
instance (IsVar a, a ~ VarOf a) => BV (TyDecl a) where
bvs _ = Set.empty
instance (IsVar a, a ~ VarOf a) => BV (TExpr a) where
bvs _ = Set.empty
instance (IsVar a, a ~ VarOf a) => BV (Expr a) where
bvs _ = Set.empty
instance (IsVar a, a ~ VarOf a) => BV (BinOp a) where
bvs _ = Set.empty
instance (IsVar a, a ~ VarOf a) => BV (Literal a) where
bvs _ = Set.empty
instance (IsVar a, a ~ VarOf a) => BV (APat a) where
bvs _ = Set.empty
instance (IsVar a, a ~ VarOf a) => BV (RowAPat a) where
bvs _ = Set.empty
instance (IsVar a, a ~ VarOf a) => BV (LVal a) where
bvs _ = Set.empty
instance (IsVar a, a ~ VarOf a) => BV (Pol a) where
bvs _ = Set.empty
instance (IsVar a, a ~ VarOf a) => BV (Mon a) where
bvs _ = Set.empty
instance (IsVar a, a ~ VarOf a) => BV (MCoef a) where
bvs _ = Set.empty
instance (IsVar a, a ~ VarOf a) => BV (MBase a) where
bvs _ = Set.empty
--------------------------------------------------------------------------------
-- Variable substitution
--------------------------------------------------------------------------------
infixl 7 ~>
infixl 6 +>
infixl 5 \\
infixl 4 .$.
infixr 4 <|>
-- | Variable substitution
class (IsVar v1, IsVar v2) => Renamable v1 v2 where
-- | Remaning environment
data SEnv v1 v2 :: *
-- | Capture predicate
captures :: SEnv v1 v2 -> Set v1 -> Set v1 -> Bool
-- | Empty renaming environment
emptyRN :: SEnv v1 v2
-- | Singleton environment where substitution @v1 -> v2@ is stored
(~>) :: v1 -> v2 -> SEnv v1 v2
-- | Returns the variable that should replace @v1@ from the remaing
-- environment
(.$.) :: SEnv v1 v2 -> v1 -> v2
-- | (Left-biased) Union of two renaming environments
(+>) :: SEnv v1 v2 -> SEnv v1 v2 -> SEnv v1 v2
-- | Removes a set of variables from the domain of the renaming
-- environment
(\\) :: SEnv v1 v2 -> Set v1 -> SEnv v1 v2
instance Renamable Name Name where
data SEnv Name Name = NN (Map Name Name)
captures (NN s) bs
= Set.fold goC False
where goC _ True
= True
goC f False
| Just fv <- Map.lookup f s = fv `Set.member` bs
| otherwise = False
emptyRN = NN Map.empty
v1 ~> v2 = NN $ Map.insert v1 v2 Map.empty
NN s2 +> NN s1 = NN $ Map.union s1 s2
NN s \\ v = NN $ Set.fold Map.delete s v
NN s .$. v
| Just v' <- Map.lookup v s = v'
| otherwise = v
instance Renamable Var Var where
data SEnv Var Var = VV (IntMap Var)
captures (VV s) bs
= Set.fold goC False
where goC _ True
= True
goC f False
| Just fv <- IntMap.lookup (varId f) s
= fv `Set.member` bs
| otherwise
= False
emptyRN = VV IntMap.empty
v1 ~> v2 = VV $ IntMap.insert (varId v1) v2 IntMap.empty
VV s2 +> VV s1 = VV $ IntMap.union s1 s2
VV s \\ v = VV $ Set.fold (\a b -> IntMap.delete (varId a) b) s v
f@(VV s) .$. v
| Just v' <- IntMap.lookup (varId v) s = setType (varType v' <|> f) v'
| otherwise = v
-- In substitutions from Name to Var, all variables MUST be in the renaming
-- environment
instance Renamable Name Var where
data SEnv Name Var = NV (Map Name Var)
captures (NV s) bs
= Set.fold goC False
where goC _ True
= True
goC f False
| Just fv <- Map.lookup f s = varName fv `Set.member` bs
| otherwise = False
emptyRN = NV Map.empty
v1 ~> v2 = NV $ Map.insert v1 v2 Map.empty
NV s2 +> NV s1 = NV $ Map.union s1 s2
NV s \\ v = NV $ Set.fold Map.delete s v
NV s .$. v
| Just v' <- Map.lookup v s = v'
| otherwise = error $ "<Language.CAO.Syntax.Utils>.\
\<rename>: Not in scope" ++ showPprDebug v
--------------------------------------------------------------------------------
-- Types where substitution is defined
type family RNTy t v :: *
type instance RNTy Name t = t
type instance RNTy Var t = t
type instance RNTy [a] b = [RNTy a b]
type instance RNTy (Maybe a) b = Maybe (RNTy a b)
type instance RNTy (Located a) b = Located (RNTy a b)
type instance RNTy (Prog a) b = Prog (RNTy a b)
type instance RNTy (Def a) b = Def (RNTy a b)
type instance RNTy (Fun a) b = Fun (RNTy a b)
type instance RNTy (TyDef a) b = TyDef (RNTy a b)
type instance RNTy (VarDecl a) b = VarDecl (RNTy a b)
type instance RNTy (LVal a) b = LVal (RNTy a b)
type instance RNTy (Stmt a) b = Stmt (RNTy a b)
type instance RNTy (Arg a) b = Arg (RNTy a b)
type instance RNTy (Literal a) b = Literal (RNTy a b)
type instance RNTy (Class a) b = Class (RNTy a b)
type instance RNTy (Type a) b = Type (RNTy a b)
type instance RNTy (Mod a) b = Mod (RNTy a b)
type instance RNTy (TyDecl a) b = TyDecl (RNTy a b)
type instance RNTy (APat a) b = APat (RNTy a b)
type instance RNTy (RowAPat a) b = RowAPat (RNTy a b)
type instance RNTy (Expr a) b = Expr (RNTy a b)
type instance RNTy (TExpr a) b = TExpr (RNTy a b)
type instance RNTy (BinOp a) b = BinOp (RNTy a b)
type instance RNTy (Pol a) b = Pol (RNTy a b)
type instance RNTy (Mon a) b = Mon (RNTy a b)
type instance RNTy (MCoef a) b = MCoef (RNTy a b)
type instance RNTy (MBase a) b = MBase (RNTy a b)
type instance RNTy (ICond a) b = ICond (RNTy a b)
type instance RNTy (IExpr a) b = IExpr (RNTy a b)
-- INVARIANT: Variable capture MUST NOT happen.
-- | Renamables for variables types
class RN t where
(<|>) :: (Renamable v0 v, VarOf t ~ v0, VarOf v0 ~ v0)
=> t -> SEnv v0 v -> RNTy t v
substLst :: (Renamable v0 v, VarOf t ~ v0, VarOf v0 ~ v0)
=> [t] -> SEnv v0 v -> [RNTy t v]
substLst lst f = map (<|> f) lst
-- Renamables for variable types
instance RN Name where
n <|> s = s .$. n
instance RN Var where
n <|> s = s .$. n
rnTuple :: (Renamable v0 c,
RN a, RN b,
VarOf a ~ v0, VarOf b ~ v0, VarOf v0 ~ v0)
=> (a, b) -> SEnv v0 c -> (RNTy a c, RNTy b c)
rnTuple (a,b) f = (a <|> f, b <|> f)
-- Renamables for containers
instance RN a => RN [a] where
lst <|> f = substLst lst f
instance RN a => RN (Maybe a) where
Nothing <|> _ = Nothing
(Just v) <|> f = Just $ v <|> f
instance RN a => RN (Located a) where
(L l v) <|> f = L l $ v <|> f
-- Substitution of top-level variables:
-- > Substitute all variables except local vars bound
-- > by local variables.
--
-- Example:
-- def v0 : ...
--
-- def f ( ... v0 ...) { ... v0 ... }
-- def g ( ... ) { ... v0 ... }
--
-- subst v0 ~> v1
--
-- def v1 : ...
--
-- def f ( ... v0 ...) { ... v0 ... }
-- def g ( ... ) { ... v1 ... }
--
instance RN a => RN (Prog a) where
Prog defs ip <|> f = Prog (defs <|> f) (ip <|> f)
instance RN a => RN (Def a) where
VarDef vd <|> f = VarDef $ vd <|> f
FunDef vd <|> f = FunDef $ vd <|> f
TyDef vd <|> f = TyDef $ vd <|> f
_ <|> _ = error "<Language.CAO.Syntax.Utils>.\
\<instance RN [Def a]>: Not defined!"
substLst [] _ = []
substLst (d:ds) f
| captures f (bvs d) (fvs ds)
= error "<Language.CAO.Syntax.Utils>.\
\<instance RN [Def a]>: Variable capture!"
| otherwise
= (d <|> f) : substLst ds f
instance RN a => RN (Fun a) where
Fun n args rt stmts <|> f
| captures f bs fs
= error "<Language.CAO.Syntax.Utils>.\
\<instance RN (Fun a)>: Variable capture!"
| otherwise
= Fun n' args' rt' stmts'
where n' = n <|> f'
args' = args <|> f'
rt' = rt <|> f'
stmts' = stmts <|> f'
f' = f \\ bs
fs = fvs args `Set.union` fvs stmts
bs = fvs n `Set.union` fvs args
instance RN a => RN (TyDef a) where
TySynDef n td <|> f
= TySynDef (n <|> f') (td <|> f')
where f' = f \\ fvs n
StructDecl n flds <|> f
= StructDecl (n <|> f') (map (`rnTuple` f') flds)
where f' = f \\ fvs n `Set.union` fvs (map fst flds)
instance RN a => RN (VarDecl a) where
VarD n td i <|> f = VarD (n <|> f') (td <|> f') (i <|> f')
where f' = f \\ fvs n
MultiD ns td <|> f = MultiD (ns <|> f') (td <|> f')
where f' = f \\ fvs ns
ContD n td is <|> f = ContD (n <|> f') (td <|> f') (is <|> f')
where f' = f \\ fvs n
instance RN a => RN (LVal a) where
LVVar v <|> f = LVVar $ v <|> f
LVStruct lv fi <|> f = LVStruct (lv <|> f) (fi <|> f)
LVCont t lv pat <|> f = LVCont (t <|> f) (lv <|> f) (pat <|> f)
instance RN a => RN (Stmt a) where
VDecl vd <|> f =
VDecl (vd <|> f)
Assign lvs es <|> f =
Assign (lvs <|> f) (es <|> f)
FCallS n es <|> f =
FCallS (n <|> f) (es <|> f)
Ret e <|> f =
Ret (e <|> f)
Ite i t e <|> f =
Ite (i <|> f) (t <|> f) (e <|> f)
Seq (SeqIter v s e b r) ss <|> f
| captures f (fvs v) freevs
= error "<Language.CAO.Syntax.Utils>.<instance RN Stmt>:\
\ variable capture!"
| otherwise
= Seq ( SeqIter (v <|> f')
(s <|> f')
(e <|> f')
(b <|> f')
r )
( ss <|> f' )
where freevs = fvs s
`Set.union` fvs e
`Set.union` fvs b
`Set.union` fvs ss
f' = f \\ fvs v
While e ss <|> f =
While (e <|> f) (ss <|> f)
Nop a <|> _ = Nop a
_ <|> _ = error "<Language.CAO.Syntax.Utils>.\
\<instance RN [Stmt a]>: Not defined!"
substLst [] _
= []
substLst (s:ss) f
| captures f (bvs s) (fvs ss)
= error "<Language.CAO.Syntax.Utils>.\
\<instance RN [Stmt a]>: Variable capture!"
| otherwise
= (s <|> f) : substLst ss f
instance RN a => RN (Arg a) where
Arg n td <|> f = Arg (n <|> f) (td <|> f)
_ <|> _ = error "<Language.CAO.Syntax.Utils>.\
\<instance RN [Arg a]>: Not defined!"
substLst [] _ = []
substLst (a:as) f
| captures f (fvs a) (fvs as)
= error "<Language.CAO.Syntax.Utils>.\
\<instance RN [Arg a]>: Variable capture!"
| otherwise
= (a <|> f) : substLst as f
instance RN a => RN (Literal a) where
ILit p <|> _ = ILit p
BLit p <|> _ = BLit p
BSLit s p <|> _ = BSLit s p
PLit p <|> f = PLit $ p <|> f
instance RN a => RN (Class a) where
Pure <|> _ = Pure
RO <|> _ = RO
Proc lst <|> f = Proc $ lst <|> f
instance RN a => RN (Type a) where
Index v c t <|> f = Index (v <|> f) (c <|> f) (t <|> f)
Mod ty ti p <|> f = Mod (ty <|> f) (ti <|> f) (p <|> f)
Vector i ty <|> f = Vector (i <|> f) (ty <|> f)
Matrix i j ty <|> f = Matrix (i <|> f) (j <|> f) (ty <|> f)
TySyn n ty <|> f = TySyn (n <|> f) (ty <|> f)
FuncSig args rt c <|> f = FuncSig (args <|> f) (rt <|> f) (c <|> f)
Struct n flds <|> f = Struct (n <|> f) (map (`rnTuple` f) flds)
SField n ty <|> f = SField (n <|> f) (ty <|> f)
Indet ty <|> f = Indet (ty <|> f)
Tuple tys <|> f = Tuple (tys <|> f)
Bits s n <|> f = Bits s (n <|> f)
Int <|> _ = Int
RInt <|> _ = RInt
Bool <|> _ = Bool
Bullet <|> _ = Bullet
-- These should not be needed in the end
TyVar n <|> _ = TyVar n
IntVar n <|> _ = IntVar n
ModVar n <|> _ = ModVar n
instance RN a => RN (Mod a) where
ModNum e <|> f = ModNum $ e <|> f
ModPol td ti pol <|> f = ModPol (td <|> f) (ti <|> f) (pol <|> f)
instance RN a => RN (TyDecl a) where
IntD <|> _ = IntD
RIntD <|> _ = RIntD
BoolD <|> _ = BoolD
BitsD s e <|> f = BitsD s $ e <|> f
ModD m <|> f = ModD $ m <|> f
VectorD e td <|> f = VectorD (e <|> f) (td <|> f)
MatrixD e1 e2 td <|> f = MatrixD (e1 <|> f) (e2 <|> f) (td <|> f)
TySynD v <|> f = TySynD (v <|> f)
instance RN a => RN (APat a) where
VectP rp <|> f = VectP $ rp <|> f
MatP rp cp <|> f = MatP (rp <|> f) (cp <|> f)
instance RN a => RN (RowAPat a) where
CElem e <|> f = CElem $ e <|> f
CRange e1 e2 <|> f = CRange (e1 <|> f) (e2 <|> f)
instance RN a => RN (TExpr a) where
TyE ty e <|> f = TyE (ty <|> f) (e <|> f)
instance RN a => RN (Expr a) where
Var v <|> f = Var $ v <|> f
Lit l <|> f = Lit (l <|> f)
FunCall n args <|> f = FunCall (n <|> f) (args <|> f)
StructProj e fi <|> f = StructProj (e <|> f) (fi <|> f)
UnaryOp op e <|> f = UnaryOp op $ e <|> f
BinaryOp op e1 e2 <|> f = BinaryOp (op <|> f) (e1 <|> f) (e2 <|> f)
Access td pat <|> f = Access (td <|> f) (pat <|> f)
Cast b td e <|> f = Cast b (td <|> f) (e <|> f)
instance RN a => RN (BinOp a) where
ArithOp op <|> _ = ArithOp op
BoolOp op <|> _ = BoolOp op
BitOp op <|> _ = BitOp op
BitsSROp op <|> _ = BitsSROp op
CmpOp ty op <|> f = CmpOp (ty <|> f) op
Concat <|>_ = Concat
-- Renaming for polynomials
instance RN a => RN (Pol a) where
Pol ms <|> f = Pol $ ms <|> f
instance RN a => RN (Mon a) where
Mon c e <|> f = Mon (c <|> f) (e <|> f)
instance RN a => RN (MCoef a) where
CoefP p <|> f = CoefP $ p <|> f
CoefI i <|> f = CoefI $ i <|> f
instance RN a => RN (MBase a) where
EZero <|> _ = EZero
MExpI n e <|> f = MExpI (n <|> f) e
-- TODO: Capture avoiding!!
instance RN a => RN (ICond a) where
IBool b <|> _ = IBool b
IBInd v <|> f = IBInd $ v <|> f
INot e <|> f = INot $ e <|> f
IAnd le <|> f = IAnd $ le <|> f
ILeq e <|> f = ILeq $ e <|> f
IEq e <|> f = IEq $ e <|> f
IBoolOp op e1 e2 <|> f = IBoolOp op (e1 <|> f) (e2 <|> f)
instance RN a => RN (IExpr a) where
IInt n <|> _ = IInt n
IInd v <|> f = IInd $ v <|> f
ISum le <|> f = ISum $ le <|> f
ISym e <|> f = ISym $ e <|> f
IArith op e1 e2 <|> f = IArith op (e1 <|> f) (e2 <|> f)
-- | Substitutions
class Subst f where
-- | Substitution of variable @v0@ by @v1@.
subst :: (VarOf f ~ v0, SubstOf f ~ v1) => (v0, v1) -> f -> f
substBlock :: (VarOf f ~ v0, SubstOf f ~ v1) => (v0, v1) -> [f] -> [f]
substBlock v = map (subst v)
instance Subst a => Subst (Located a) where
subst f = fmap (subst f)
instance Subst a => Subst (Maybe a) where
subst f = fmap (subst f)
instance Subst a => Subst [a] where
subst = substBlock
instance Eq a => Subst (RowAPat a) where
subst f (CElem e) = CElem $ subst f e
subst f (CRange e1 e2) = CRange (subst f e1) (subst f e2)
instance Eq a => Subst (APat a) where
subst f (VectP e) = VectP $ subst f e
subst f (MatP e1 e2) = MatP (subst f e1) (subst f e2)
instance Eq a => Subst (TExpr a) where
subst f (TyE ty e) = TyE ty (subst f e)
instance Eq a => Subst (Expr a) where
subst (v0, e) v@(Var v1)
| v1 == v0 = e
| otherwise = v
subst _ l@(Lit _) = l
subst f (FunCall n es) = FunCall n $ map (subst f) es
subst f (StructProj e n) = StructProj (subst f e) n
subst f (UnaryOp op e) = UnaryOp op (subst f e)
subst f (BinaryOp op e1 e2) = BinaryOp op (subst f e1) (subst f e2)
subst f (Access e p) = Access (subst f e) (subst f p)
subst f (Cast b td e) = Cast b (subst f td) (subst f e)
instance Eq a => Subst (BinOp a) where
subst _ c = c
instance Eq a => Subst (TyDecl a) where
subst f (BitsD s e) = BitsD s $ subst f e
subst f (ModD m) = ModD $ subst f m
subst f (VectorD e td) = VectorD (subst f e) (subst f td)
subst f (MatrixD r c td) = MatrixD (subst f r) (subst f c) (subst f td)
subst _ d = d
instance Eq a => Subst (Mod a) where
subst f (ModNum e) = ModNum $ subst f e
subst f (ModPol td n pol) = ModPol (subst f td) n pol
instance Eq a => Subst (Stmt a) where
subst f (VDecl vd) = VDecl (subst f vd)
subst f (Assign lvs es) = Assign (map (subst f) lvs) (map (subst f) es)
subst f (FCallS n es) = FCallS n $ map (subst f) es
subst f (Ret es) = Ret $ map (subst f) es
subst f (Ite i t e) = Ite (subst f i) (subst f t) (subst f e)
subst f@(v0,_) sq@(Seq (SeqIter v1 s e b r) ss)
| v0 == v1 = sq
| otherwise = Seq (SeqIter v1 (subst f s)
(subst f e)
(subst f b)
r ) $ subst f ss
subst f (While e ss) = While (subst f e) (subst f ss)
subst _ (Nop a) = Nop a
subst _ _ = error "<Language.CAO.Syntax.Utils>.\
\<instance Subst [Stmt a]>: Not defined!"
substBlock _ [] = []
substBlock f@(v0, _) ss@(VDecl vd : rest)
| v0 `elem` getDeclVar vd = ss
| otherwise = VDecl (subst f vd) : substBlock f rest
substBlock f (s:ss) = subst f s : subst f ss
instance Eq a => Subst (LVal a) where
subst _ v@(LVVar _) = v
subst f (LVStruct lv e) = LVStruct (subst f lv) e
subst f (LVCont ty lv pat) = LVCont ty (subst f lv) (subst f pat)
instance Eq a => Subst (VarDecl a) where
subst f (VarD n td e) = VarD n (subst f td) (subst f e)
subst f (MultiD n td) = MultiD n (subst f td)
subst f (ContD n td es) = ContD n (subst f td) $ map (subst f) es
instance Eq a => Subst (Pol a) where
subst f (Pol ps) = Pol (map (subst f) ps)
instance Eq a => Subst (Mon a) where
subst f (Mon c b) = Mon (subst f c) b
instance Eq a => Subst (MCoef a) where
subst f (CoefI i) = CoefI $ subst f i
subst f (CoefP p) = CoefP $ subst f p
instance Eq a => Subst (Type a) where
subst _ Int = Int
subst _ RInt = RInt
subst _ Bool = Bool
subst f (Bits b i) = Bits b $ subst f i
subst f (Mod a b c) = Mod (subst f a) b (subst f c)
subst f (Vector n t) = Vector (subst f n) (subst f t)
subst f (Matrix n m t) = Matrix (subst f n) (subst f m) (subst f t)
subst f (TySyn v t) = TySyn v (subst f t)
subst f (FuncSig ta tr c) = FuncSig (map (subst f) ta) (subst f tr) c
subst f (Struct v t) = Struct v (map (mapSnd (subst f)) t)
subst f (SField v t) = SField v (subst f t)
subst f (Indet t) = Indet (subst f t)
subst f (Tuple t) = Tuple $ subst f t
subst _ Bullet = Bullet
subst f (Index v c t) = Index v (subst f c) (subst f t)
subst _ _ = error "<Language.CAO.Syntax.Utils>.\
\<instance Subst [Type a]>: Not defined!"
instance Eq a => Subst (ICond a) where
subst _ v@(IBInd _) = v
subst _ l@(IBool _) = l
subst f (INot e) = INot $ subst f e
subst f (IAnd le) = IAnd $ map (subst f) le
subst f (IBoolOp op e1 e2) = IBoolOp op (subst f e1) (subst f e2)
subst f (ILeq e) = ILeq $ subst f e
subst f (IEq e) = IEq $ subst f e
instance Eq a => Subst (IExpr a) where
subst (v0, e) v@(IInd v1)
| v1 == v0 = e
| otherwise = v
subst _ l@(IInt _) = l
subst f (ISum le) = ISum $ map (subst f) le
subst f (ISym e) = ISym $ subst f e
subst f (IArith op e1 e2) = IArith op (subst f e1) (subst f e2)
--------------------------------------------------------------------------------
-- General Utils
--
lvname :: LVal id -> id
lvname (LVVar v) = unLoc v
lvname (LVStruct lv _) = lvname lv
lvname (LVCont _ lv _) = lvname lv
lvalNames :: Ord id => [LStmt id] -> Set id
lvalNames = foldl' lvalNames' Set.empty
where
lvalNames' vs (unLoc -> Assign lvs _)
= vs `Set.union` Set.fromList (map lvname lvs)
lvalNames' vs (unLoc -> Ite _ t e)
= vs `Set.union` lvalNames t `Set.union` maybe Set.empty lvalNames e
lvalNames' vs (unLoc -> While _ ss')
= vs `Set.union` lvalNames ss'
lvalNames' vs (unLoc -> Seq _ ss')
= vs `Set.union` lvalNames ss'
lvalNames' vs _
= vs
getVars :: LStmt Var -> [Var]
getVars ss = Set.toList $ Set.filter nsVar $ fvs ss
getLVars :: Ord id => LStmt id -> [id]
getLVars ss = Set.toList $ lvalNames [ss]
getRVars :: LStmt Var -> [Var]
getRVars ss = Set.toList $ Set.filter nsVar (fvs ss) Set.\\ lvalNames [ss]
sameKind :: LStmt Var -> LStmt Var -> Bool
(L _ s1) `sameKind` (L _ s2) = s1 `doSK` s2
where
doSK :: Stmt Var -> Stmt Var -> Bool
doSK (VDecl _) (VDecl _)
= True
doSK (Assign lvs1 es1) (Assign lvs2 es2)
| length lvs1 == length lvs2 && length es1 == length es2
= all (uncurry sameKindExpr) $ zip es1 es2
doSK (FCallS fn1 es1) (FCallS fn2 es2)
= fn1 == fn2 && all (uncurry sameKindExpr) (zip es1 es2)
doSK (Ret es1) (Ret es2)
= all (uncurry sameKindExpr) $ zip es1 es2
doSK (Ite i1 t1 Nothing) (Ite i2 t2 Nothing)
= sameKindExpr i1 i2 && all (uncurry sameKind) (zip t1 t2)
doSK (Ite i1 t1 (Just e1)) (Ite i2 t2 (Just e2))
= sameKindExpr i1 i2 && all (uncurry sameKind) (zip t1 t2)
&& all (uncurry sameKind) (zip e1 e2)
doSK (Seq si1 ss1) (Seq si2 ss2)
| seqIdx si1 == seqIdx si2 = all (uncurry sameKind) (zip ss1 ss2)
doSK (While _ _) (While _ _)
= False -- Need to have same number of iterations
doSK _ _
= False
-- TODO: Review pattern: | guard = True. Is there any good reason to use this?
sameKindExpr :: TLExpr Var -> TLExpr Var -> Bool
sameKindExpr (L _ (TyE _ le1)) (L _ (TyE _ le2)) = ske le1 le2
where
ske (Var _) (Var _)
= True
ske (Lit _) (Lit _)
= True
ske (FunCall (L _ fn1) es1) (FunCall (L _ fn2) es2)
| fn1 == fn2 && all (uncurry sameKindExpr) (zip es1 es2)
= True
ske (StructProj e1 _ ) (StructProj e2 _ )
| sameKindExpr e1 e2
= True
ske (BinaryOp op1 e11 e12) (BinaryOp op2 e21 e22)
| op1 == op2 && sameKindExpr e11 e21 && sameKindExpr e12 e22
= True
ske (UnaryOp op1 e1) (UnaryOp op2 e2)
= op1 == op2 && sameKindExpr e1 e2
ske (Access e1 p1) (Access e2 p2)
= sameKindExpr e1 e2 && sameKindPat p1 p2
ske (Cast _ _ e1) (Cast _ _ e2)
= sameKindExpr e1 e2
ske _ _
= False
sameKindPat :: APat Var -> APat Var -> Bool
sameKindPat (VectP rp1) (VectP rp2)
= sameKindRP rp1 rp2
sameKindPat (MatP rp1 cp1) (MatP rp2 cp2)
= sameKindRP rp1 rp2 && sameKindRP cp1 cp2
sameKindPat _ _
= False
sameKindRP :: RowAPat Var -> RowAPat Var -> Bool
sameKindRP (CElem e1) (CElem e2)
= sameKindExpr e1 e2
sameKindRP (CRange e11 e12) (CRange e21 e22)
= sameKindExpr e11 e21 && sameKindExpr e12 e22
sameKindRP _ _
= False
isAscSeq :: SeqIter id -> Bool
isAscSeq = maybe True aux . seqBy
where
aux :: LExpr id -> Bool
aux (L _ (Lit (ILit n))) = n > 0
aux _ = error "<isAscSeq>: not expected case"
{-# INLINE isSimpleLVal #-}
isSimpleLVal :: LVal id -> Bool
isSimpleLVal (LVVar _) = True
isSimpleLVal _ = False
{-# INLINE isAssignStmt #-}
isAssignStmt :: Stmt id -> Bool
isAssignStmt (Assign _ _) = True
isAssignStmt _ = False
{-# INLINE isLit #-}
isLit :: Expr id -> Bool
isLit (Lit _) = True
isLit _ = False
{-# INLINE isIntLit #-}
isIntLit :: Expr id -> Bool
isIntLit (Lit (ILit _)) = True
isIntLit _ = False
{-# INLINE isSimpleVDecl #-}
isSimpleVDecl :: Stmt id -> Bool
isSimpleVDecl (VDecl (VarD {})) = True
isSimpleVDecl (VDecl (MultiD {})) = True
isSimpleVDecl _ = False
{-# INLINE isReturn #-}
isReturn :: Stmt a -> Bool
isReturn (Ret _) = True
isReturn _ = False
defVar :: LDef id -> [id]
defVar = defV . unLoc
where
defV (VarDef (VarD n _ _)) = [unLoc n]
defV (VarDef (MultiD n _)) = map unLoc n
defV (VarDef (ContD n _ _)) = [unLoc n]
defV (ConstDef (ConstD n _ _)) = [unLoc n]
defV (ConstDef (MultiConstD n _ _)) = map unLoc n
defV (FunDef f) = [unLoc $ funId f]
defV (TyDef (TySynDef t _)) = [unLoc t]
defV (TyDef (StructDecl s _)) = [unLoc s]
getDeclVar :: VarDecl id -> [id]
getDeclVar (VarD n _ _) = [unLoc n]
getDeclVar (MultiD n _) = map unLoc n
getDeclVar (ContD n _ _) = [unLoc n]
{-# INLINE isRange #-}
isRange :: APat id -> Bool
isRange (VectP (CRange _ _)) = True
isRange (MatP (CRange _ _) _) = True
isRange (MatP _ (CRange _ _)) = True
isRange _ = False
{-# INLINE isEqNeq #-}
isEqNeq :: COp -> Bool
isEqNeq bop = case bop of
Eq -> True
Neq -> True
_ -> False
type2TyDecl :: Type Var -> TyDecl Var
type2TyDecl Int = IntD
type2TyDecl RInt = RIntD
type2TyDecl Bool = BoolD
type2TyDecl (Bits s n) = BitsD s (ind2Expr n)
type2TyDecl (Mod Nothing Nothing (Pol [Mon (CoefI n) EZero]))
= ModD $ ModNum $ ind2Expr n
type2TyDecl (Mod (Just b) (Just i) p)
= ModD $ ModPol (type2TyDecl b) i p
type2TyDecl (Vector k it)
= VectorD (ind2Expr k) (type2TyDecl it)
type2TyDecl (Matrix u v it)
= MatrixD (ind2Expr u) (ind2Expr v) (type2TyDecl it)
type2TyDecl (Struct sn _)
= TySynD (L genSrcLoc sn)
type2TyDecl (SField _ t) = type2TyDecl t
type2TyDecl (Index _ _ t) = type2TyDecl t
type2TyDecl t
= error $ "<Utils.hs>.<type2TyDecl>: " ++ showPprDebug t
class Typeable a where
typeOf :: a -> Type Var
instance Typeable Var where
typeOf = varType
instance Typeable (TExpr Var) where
typeOf (TyE t _) = t
instance Typeable (LVal Var) where
typeOf (LVVar v) = varType $ unLoc v
typeOf (LVStruct lv fi) = fieldType fi (typeOf lv)
typeOf (LVCont ty _ _) = ty
instance Typeable a => Typeable (Located a) where
typeOf (L _ e) = typeOf e
instance Typeable (IExpr Var) where
typeOf = queryIndexTy
instance Typeable (Type Var) where
typeOf = id